=======================================================================================

1 Preface

When done right, graphs can be appealing, informative, and of considerable value to an academic article. Unfortunately, researchers generally suck at making good graphs. We surmise that this is because researchers do not completely master their graphing software, and they are either too lazy or too busy to remedy the situation. Consequently, the produced graph is often a severe distortion of the ideal Platonian graph that the researcher had in mind initially.

This compendium facilitates the creation of good graphs by presenting a set of concrete examples, ranging from the trivial to the advanced. The graphs can all be reproduced and adjusted by copy-pasting code into the R console. A note for R fans: the majority of our plots have been created in base R, but you will encounter some examples in ggplot.

Almost every example in this compendium is driven by the same philosophy: A good graph is a simple graph, in the Einsteinian sense that a graph should be made as simple as possible, but not simpler.

We close with a request and a piece of advice. The request: if you create a clean graph in R that you believe is a candidate for inclusion in this compendium, please do not hesitate to contact us at EJ.Wagenmakers@gmail.com or quentingronau@web.de. Your contribution will be acknowledged explicitly, alongside the code you provided. The advice: when you create a clean graph in R, put it on Flickr (public license) before you sign away your copyright to a publisher. For an example, see Figure 1 from this paper.

This work has profited greatly from interactions with our colleagues, many of whom have contributed graphs of their own.

2 Introduction

Producing clean graphs can be a challenging task. First you have to consider what is the best way in which to convey the information: a line graph, a histogram, a multi-panel plot; such conceptual dilemma’s are not dealt with in this compendium, and instead we recommend the reader to the chapters on creating graphs in the excellent book by Briscoe (1996). Second, you have to use computer software to translate the conceptual graph to a publication-ready figure. This is the phase where this compendium may be useful, because it brings together R code for producing a set of clean, publication-ready figures. Hopefully this will make it easy to copy-paste and adjust the code to suit your own needs.

In our experience, many graphs can be dramatically improved by adhering to the following guidlines: (1) invest sufficient time and effort in the process; (2) omit needless graphical elements, that is, make every element count; (3) judge the relative impact of the graphical elements and ensure that they are in balance; (4) use large font sizes for all text; (5) deviate from the R default settings – with a little effort, you can do a lot better.

This compendium does not discuss figure headings. However, we will say that it is clearly desirable to have the main message of a figure be understood without being forced to read the main text. If possible, start your figure heading by stating what the figure is meant to demonstrate (i.e., its interpretation). For example, do not state “Popularity as a function of president height”; instead, state “Taller presidents are more popular”.

Finally, a note on color. Many graphs look better in color, but there are two complications. First, some academic journals do not publish manuscripts in color, at least not without charging a hefty price. Second, many readers and reviewers do not have a color printer. Below, some graphs have color, whereas others only use grey-scales. Of course this is one of the easiest things to adjust.

Based on this compendium, learning to create good graphs in R will be 80% copy-paste and 20% tinkering. Let’s go plot ourselves some graphs!

3 Correlations

Whenever a researcher reports a correlation, it is imperative to plot the data. Anscombe’s quartet (plotted below) is a famous demonstration of this fact.

3.1 The Electoral Advantage of Being Tall

This plot shows the relation between the height ratio of US presidents and the percentage of the popular vote. Note the large circles for the data, the thick line for the linear relation, and the large font size for the axis labels. Also, note that the line does not touch the y-axis (a subtlety that requires deviating from the default).

Show R-Code
# Presidential data up to and including 2008; data from Stulp et al. 2013
# rm(list=ls())
# height of president divided by height of most successful opponent: 
height.ratio <- c(0.924324324, 1.081871345, 1, 0.971098266, 1.029761905,
   0.935135135, 0.994252874, 0.908163265, 1.045714286, 1.18404908,
   1.115606936, 0.971910112, 0.97752809, 0.978609626, 1,
   0.933333333, 1.071428571, 0.944444444, 0.944444444, 1.017142857,
   1.011111111, 1.011235955, 1.011235955, 1.089285714, 0.988888889,
   1.011111111, 1.032967033, 1.044444444, 1, 1.086705202,
   1.011560694, 1.005617978, 1.005617978, 1.005494505, 1.072222222,
   1.011111111, 0.983783784, 0.967213115, 1.04519774, 1.027777778,
   1.086705202, 1, 1.005347594, 0.983783784, 0.943005181, 1.057142857)

# proportion popular vote for president vs most successful opponent
# NB can be lower than .5 because popolar vote does not decide election
pop.vote <- c(0.427780852, 0.56148981, 0.597141922, 0.581254292, 0.530344067,
  0.507425996, 0.526679292, 0.536690951, 0.577825976, 0.573225387,
  0.550410082, 0.559380032, 0.484823958, 0.500466176, 0.502934212,
  0.49569636, 0.516904414, 0.522050547, 0.531494442, 0.60014892, 
  0.545079801, 0.604274986, 0.51635906, 0.63850958, 0.652184407, 
  0.587920412, 0.5914898, 0.624614752, 0.550040193, 0.537771958, 
  0.523673642, 0.554517134, 0.577511576, 0.500856251, 0.613444534, 
  0.504063153, 0.617883695, 0.51049949, 0.553073235, 0.59166415, 
  0.538982024, 0.53455133, 0.547304058, 0.497350649, 0.512424242, 
  0.536914796)
           
# cor.test(height.ratio,pop.vote)
library(plotrix) # package plotrix is needed for function "ablineclip""
# if the following line and the line containing "dev.off()" are executed, the plot will be saved as a png file in the current working directory
# png("Presidental.png", width = 18, height = 18, units = "cm", res = 800, pointsize = 10) 
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5 , font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(height.ratio, pop.vote, col = "black", pch = 21, bg = "grey", cex = 2,
     xlim = c(.90,1.20), ylim = c(.40,.70), ylab = "", xlab = "", axes = FALSE)
axis(1)
axis(2) 
reg1 <- lm(pop.vote ~ height.ratio)
ablineclip(reg1, lwd = 2,x1 = .9, x2 = 1.2) 
par(las = 0)
mtext("Presidential Height Ratio", side = 1, line = 2.5, cex = 1.5)
mtext("Relative Support for President", side = 2, line = 3.7, cex = 1.5)
text(1.15, .65, "r = .39", cex = 1.5)
# dev.off()
# For comparison, consider the default plot:
# par(op) # reset to default "par" settings
# plot(height.ratio, pop.vote) #yuk!

4 Histograms

Histograms are relatively straightforward to create and to interpret. In fact, some people may even find them boring. Luckily, it is easy to increase the reader’s interest level by adding information to the plot. Below we illustrate various ways by which this may be accomplished.

4.1 Including “rug” Tick Marks

When in doubt, add tick marks that showcase the individual data points. This is particularly useful when the number of data points is small. The code below is courtesy of Helen Steingroever. Note that the rug tick marks are jittered.

Show R-Code
# rm(list = ls())
# Data: Proportion of choices from the good decks as reported in 39 studies
good.choices <- c(.43, .47, .47, .48, .50, .52, .53, .53, .54, .54, .54, .54, .55, .55, .55, .56, .56, .57, .57, .57, .57, .58, .58, .58, .59, .59, .60, .62, .63, .63, .64, .64, .66, .66, .67, .67, .68, .70, .70)
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5 , font.lab = 2, cex.axis = 1.3, bty = "n", las=1)
hist(good.choices, main = "", xlab = "", ylab = " ", ylim = c(0, 13), xlim = c(.30, .80), axes = FALSE, col = "grey")
axis(1, seq(.30, .80, by = .1))
axis(2, seq(.00,  12, by = 2))
rug(jitter(good.choices))
mtext("Prop. Choices from Good Decks", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Number of Studies", side = 2, line = 3, cex = 1.5, font = 2, las = 0)

4.2 Including a Density Estimator

In R, it is easy to include a nonparametric density estimator. This requires that freq = FALSE in the histogram comment. Courtesy of Helen Steingroever.

Show R-Code
# rm(list = ls())
# Data: Proportion of choices from the good decks as reported in 39 studies
good.choices <- c(.43, .47, .47, .48, .50, .52, .53, .53, .54, .54, .54, .54, .55, .55, .55, .56, .56, .57, .57, .57, .57, .58, .58, .58, .59, .59, .60, .62, .63, .63, .64, .64, .66, .66, .67, .67, .68, .70, .70)
yhigh <- 8
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5 , font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
h <- hist(good.choices, freq = FALSE, main = "", xlab = "", ylab = " ", ylim = c(0, yhigh), xlim = c(.30, .80), axes = FALSE, col = "grey")
axis(1, seq(.30, .80, by = .1))
axis(2, labels = FALSE, lwd.ticks = 0)
rug(jitter(good.choices))
mtext("Prop. Choices from Good Decks", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Density of Studies", side = 2, line = 1, cex = 1.5, font = 2, las = 0)
lines(density(good.choices), lwd = 2)

4.3 Including Numbers on Top

This example shows how to display the bar heights, using the function l_ply. Courtesy of Helen Steingroever and Quentin Gronau.

Show R-Code
# rm(list = ls())
library(plyr)  # needed for function 'l_ply'
# Data: Proportion of choices from the good decks as reported in 39 studies
good.choices <- c(0.43, 0.47, 0.47, 0.48, 0.5, 0.52, 0.53, 0.53, 0.54, 0.54, 
    0.54, 0.54, 0.55, 0.55, 0.55, 0.56, 0.56, 0.57, 0.57, 0.57, 0.57, 0.58, 0.58, 
    0.58, 0.59, 0.59, 0.6, 0.62, 0.63, 0.63, 0.64, 0.64, 0.66, 0.66, 0.67, 0.67, 
    0.68, 0.7, 0.7)
yhigh <- 8
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
h <- hist(good.choices, freq = FALSE, main = "", xlab = "", ylab = " ", ylim = c(0, 
    yhigh), xlim = c(0.3, 0.8), axes = FALSE, col = "grey")
l_ply(seq_along(h$density), function(x) text(h$mids[x], h$density[x] + 0.32, 
    round(h$density[x], 2), cex = 1.2))
axis(1, seq(0.3, 0.8, by = 0.1))
axis(2, labels = FALSE, lwd.ticks = 0)
rug(jitter(good.choices))
mtext("Prop. Choices from Good Decks", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Density of Studies", side = 2, line = 1, cex = 1.5, font = 2, las = 0)

5 Line Plots

The line plot is one of the most standard plots. Nevertheless, many researchers fail to realize that line plots deserve love and attention too.

5.1 Regular Line Plot

This graph plots error bars with a user-defined function. More to the point, the lines are thick, and they do not overlap with the symbols (type = "c"). Note that the legend is not needed; the legend text could simply have been positioned near the associated graphical elements.

Show R-Code
plotsegraph <- function(loc, value, sterr, wiskwidth, color = "grey", linewidth = 2) {
	
    w <- wiskwidth/2
    segments(x0 = loc, x1 = loc, y0 = value - sterr, y1 = value + sterr, col = color, 
        lwd = linewidth)
    segments(x0 = loc - w, x1 = loc + w, y0 = value + sterr, y1 = value + sterr, 
        col = color, lwd = linewidth)  # upper whiskers
    segments(x0 = loc - w, x1 = loc + w, y0 = value - sterr, y1 = value - sterr, 
        col = color, lwd = linewidth)  # lower whiskers
}

RT.hf.sp <- 0.41
RT.lf.sp <- 0.43
RT.vlf.sp <- 0.425
se.RT.hf.sp <- 0.01
se.RT.lf.sp <- 0.015
se.RT.vlf.sp <- 0.02
RT.hf.ac <- 0.46
RT.lf.ac <- 0.51
RT.vlf.ac <- 0.52
se.RT.hf.ac <- 0.01
se.RT.lf.ac <- 0.015
se.RT.vlf.ac <- 0.02

par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = "", xlab = " ", cex = 1.5, 
    ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = F, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)
axis(2, pos = 1.2, )
par(las = 0)
mtext(expression(paste("Mean ", mu)), side = 2, line = 2, cex = 1.5, font = 2)
x <- c(1.5, 2.5, 3.5)
points(x, c(RT.hf.sp, RT.lf.sp, RT.vlf.sp), cex = 1.5, lwd = 2, pch = 19)
plot.errbars <- plotsegraph(x, c(RT.hf.sp, RT.lf.sp, RT.vlf.sp), c(se.RT.hf.sp, 
    se.RT.lf.sp, se.RT.vlf.sp), 0.1, color = "black")  #0.1 = wiskwidth
lines(c(1.5, 2.5, 3.5), c(RT.hf.sp, RT.lf.sp, RT.vlf.sp), lwd = 2, type = "c")
points(x, c(RT.hf.ac, RT.lf.ac, RT.vlf.ac), cex = 1.5, lwd = 2, pch = 21)
plot.errbars <- plotsegraph(x, c(RT.hf.ac, RT.lf.ac, RT.vlf.ac), c(se.RT.hf.ac, 
    se.RT.lf.ac, se.RT.vlf.ac), 0.1, color = "black")  #0.1 = wiskwidth
lines(c(1.5, 2.5, 3.5), c(RT.hf.ac, RT.lf.ac, RT.vlf.ac), lwd = 2, type = "c")
points(1.5, 0.6, pch = 21, lwd = 2, cex = 1.5)
text(1.7, 0.6, "Accuracy", cex = 1.2, font = 1, adj = 0)
points(1.5, 0.57, pch = 19, lwd = 2, cex = 1.5)
text(1.7, 0.57, "Speed", cex = 1.2, font = 1, adj = 0)

5.2 Box Plot

Similar to the above, this plot shows the distribuion of the data with a user-defined boxplot function.

Show R-Code
boxplot.ej <- function(y, xloc = 1, width.box = 0.25, lwd.box = 2, width.hor = 0.25, 
    lwd.hor = 2, range.wisk = 1.5, lwd.wisk = 2, pch.box = 16, cex.boxpoint = 2, 
    plot.outliers = FALSE, pch.out = 1, cex.out = 1, color = "black") {
	
    # makes boxplot with dot as median and solid whisker Interquartile range =
    # (.75 quantile) - (.25 quantile).  Note: Wiskers are not always symmetrical;
    # top wisker extends up to max(y) constrained by y <= (.75 quantile) +
    # range.wisk*Interquartile range bottom whisker is determined by min(y)
    # constrained by y >= (.25 quantile) - range.wisk*Interquartile range
	
    Q <- quantile(y, c(0.25, 0.5, 0.75))
    names(Q) <- NULL  # gets rid of percentages
    IQ.range <- Q[3] - Q[1]
    low <- Q[1] - range.wisk * IQ.range
    high <- Q[3] + range.wisk * IQ.range
    index <- which((y >= low) & (y <= high))
    wisk.low <- min(y[index])
    wisk.high <- max(y[index])
    outliers <- y[which((y < low) | (y > high))]
    
    # plot median:
    points(xloc, Q[2], pch = pch.box, cex = cex.boxpoint, col = color)
    
    # plot box:
    xleft <- xloc - width.box/2
    xright <- xloc + width.box/2
    ybottom <- Q[1]
    ytop <- Q[3]
    rect(xleft, ybottom, xright, ytop, lwd = lwd.box, border = color)
    
    # plot whiskers:
    segments(xloc, wisk.low, xloc, Q[1], lwd = lwd.wisk, col = color)
    segments(xloc, Q[3], xloc, wisk.high, lwd = lwd.wisk, col = color)
    
    # plot horizontal segments:
    x0 <- xloc - width.hor/2
    x1 <- xloc + width.hor/2
    segments(x0, wisk.low, x1, wisk.low, lwd = lwd.hor, col = color)
    segments(x0, wisk.high, x1, wisk.high, lwd = lwd.hor, col = color)
    
    # plot outliers:
    if (plot.outliers == TRUE) {
        xloc.p <- rep(xloc, length(outliers))
        points(xloc.p, outliers, pch = pch.out, cex = cex.out, col = color)
    }
}

RT.hf.sp <- rnorm(1000, mean = 0.41, sd = 0.008)
RT.lf.sp <- rnorm(1000, mean = 0.43, sd = 0.01)
RT.vlf.sp <- rnorm(1000, mean = 0.425, sd = 0.012)
RT.hf.ac <- rnorm(1000, mean = 0.46, sd = 0.008)
RT.lf.ac <- rnorm(1000, mean = 0.51, sd = 0.01)
RT.vlf.ac <- rnorm(1000, mean = 0.52, sd = 0.012)

ps <- 1  # size of boxpoint
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5, 
    ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = FALSE, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)
axis(2, pos = 1.1)
par(las = 0)
mtext("Group Mean M", side = 2, line = 2.9, cex = 1.5, font = 2)

x <- c(1.5, 2.5, 3.5)
boxplot.ej(RT.hf.sp, xloc = 1.5, cex.boxpoint = ps)
boxplot.ej(RT.hf.ac, xloc = 1.5, cex.boxpoint = ps, color = "grey")
boxplot.ej(RT.lf.sp, xloc = 2.5, cex.boxpoint = ps)
boxplot.ej(RT.lf.ac, xloc = 2.5, cex.boxpoint = ps, color = "grey")
boxplot.ej(RT.vlf.sp, xloc = 3.5, cex.boxpoint = ps)
boxplot.ej(RT.vlf.ac, xloc = 3.5, cex.boxpoint = ps, color = "grey")

text(2.5, 0.35, "Speed", cex = 1.4, font = 1, adj = 0.5)
text(2.5, 0.57, "Accuracy", cex = 1.4, font = 1, col = "grey", adj = 0.5)

5.3 Violin Plot

By now this plot should look familiar. The distribution of the data is now indicated with a violin plot instead of a box plot. Courtesy of Henrik Singmann, who tweaked the results from the vioplot package. Warning: this a a lot of code.

Show R-Code
RT.hf.sp <- rnorm(1000, mean = 0.41, sd = 0.008)
RT.lf.sp <- rnorm(1000, mean = 0.43, sd = 0.01)
RT.vlf.sp <- rnorm(1000, mean = 0.425, sd = 0.012)
RT.hf.ac <- rnorm(1000, mean = 0.46, sd = 0.008)
RT.lf.ac <- rnorm(1000, mean = 0.51, sd = 0.01)
RT.vlf.ac <- rnorm(1000, mean = 0.52, sd = 0.012)

library(sm)

# by Henrik Singmann customized violinplot function (singmann.org) the
# original violinplot function stems from the 'vioplot' package Copyright (c)
# 2004, Daniel Adler. All rights reserved.  Redistribution and use in source
# and binary forms, with or without modification, are permitted provided that
# the following conditions are met: * Redistributions of source code must
# retain the above copyright notice, this list of conditions and the
# following disclaimer.  * Redistributions in binary form must reproduce the
# above copyright notice, this list of conditions and the following
# disclaimer in the documentation and/or other materials provided with the
# distribution.  * Neither the name of the University of Goettingen nor the
# names of its contributors may be used to endorse or promote products
# derived from this software without specific prior written permission.  THIS
# SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 'AS IS' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.

vioplot.singmann <- function(x, ..., range = 1.5, h = NULL, ylim = NULL, names = NULL, 
    horizontal = FALSE, col = NULL, border = "black", lty = 1, lwd = 1, rectCol = "black", 
    colMed = "white", pchMed = 19, at, add = FALSE, wex = 1, mark.outlier = TRUE, 
    pch.mean = 4, ids = NULL, drawRect = TRUE, yaxt = "s") {
	
    # process multiple datas
    datas <- list(x, ...)
    n <- length(datas)
    if (missing(at)) 
        at <- 1:n
    # pass 1 - calculate base range - estimate density setup parameters for
    # density estimation
    upper <- vector(mode = "numeric", length = n)
    lower <- vector(mode = "numeric", length = n)
    q1 <- vector(mode = "numeric", length = n)
    q3 <- vector(mode = "numeric", length = n)
    med <- vector(mode = "numeric", length = n)
    base <- vector(mode = "list", length = n)
    height <- vector(mode = "list", length = n)
    outliers <- vector(mode = "list", length = n)
    baserange <- c(Inf, -Inf)
    
    # global args for sm.density function-call
    args <- list(display = "none")
    
    if (!(is.null(h))) 
        args <- c(args, h = h)
    for (i in 1:n) {
        data <- datas[[i]]
        if (!is.null(ids)) 
            names(data) <- ids
        if (is.null(names(data))) 
            names(data) <- as.character(1:(length(data)))
        
        # calculate plot parameters 1- and 3-quantile, median, IQR, upper- and
        # lower-adjacent
        data.min <- min(data)
        data.max <- max(data)
        q1[i] <- quantile(data, 0.25)
        q3[i] <- quantile(data, 0.75)
        med[i] <- median(data)
        iqd <- q3[i] - q1[i]
        upper[i] <- min(q3[i] + range * iqd, data.max)
        lower[i] <- max(q1[i] - range * iqd, data.min)
        
        # strategy: xmin = min(lower, data.min)) ymax = max(upper, data.max))
        est.xlim <- c(min(lower[i], data.min), max(upper[i], data.max))
        
        # estimate density curve
        smout <- do.call("sm.density", c(list(data, xlim = est.xlim), args))
        
        # calculate stretch factor the plots density heights is defined in range 0.0
        # ... 0.5 we scale maximum estimated point to 0.4 per data
        hscale <- 0.4/max(smout$estimate) * wex
        
        # add density curve x,y pair to lists
        base[[i]] <- smout$eval.points
        height[[i]] <- smout$estimate * hscale
        t <- range(base[[i]])
        baserange[1] <- min(baserange[1], t[1])
        baserange[2] <- max(baserange[2], t[2])
        min.d <- boxplot.stats(data)[["stats"]][1]
        max.d <- boxplot.stats(data)[["stats"]][5]
        height[[i]] <- height[[i]][(base[[i]] > min.d) & (base[[i]] < max.d)]
        height[[i]] <- c(height[[i]][1], height[[i]], height[[i]][length(height[[i]])])
        base[[i]] <- base[[i]][(base[[i]] > min.d) & (base[[i]] < max.d)]
        base[[i]] <- c(min.d, base[[i]], max.d)
        outliers[[i]] <- list(data[(data < min.d) | (data > max.d)], names(data[(data < 
            min.d) | (data > max.d)]))
        
        # calculate min,max base ranges
    }
    # pass 2 - plot graphics setup parameters for plot
    if (!add) {
        xlim <- if (n == 1) 
            at + c(-0.5, 0.5) else range(at) + min(diff(at))/2 * c(-1, 1)
        
        if (is.null(ylim)) {
            ylim <- baserange
        }
    }
    if (is.null(names)) {
        label <- 1:n
    } else {
        label <- names
    }
    boxwidth <- 0.05 * wex
    
    # setup plot
    if (!add) 
        plot.new()
    if (!horizontal) {
        if (!add) {
            plot.window(xlim = xlim, ylim = ylim)
            axis(2)
            axis(1, at = at, label = label)
        }
        
        box()
        for (i in 1:n) {
            # plot left/right density curve
            polygon(c(at[i] - height[[i]], rev(at[i] + height[[i]])), c(base[[i]], 
                rev(base[[i]])), col = col, border = border, lty = lty, lwd = lwd)
            
            if (drawRect) {
                # browser() plot IQR
                boxplot(datas[[i]], at = at[i], add = TRUE, yaxt = yaxt, pars = list(boxwex = 0.6 * 
                  wex, outpch = if (mark.outlier) "" else 1))
                if ((length(outliers[[i]][[1]]) > 0) & mark.outlier) 
                  text(rep(at[i], length(outliers[[i]][[1]])), outliers[[i]][[1]], 
                    labels = outliers[[i]][[2]])
                # lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty) plot 50% KI
                # box rect( at[i]-boxwidth/2, q1[i], at[i]+boxwidth/2, q3[i], col=rectCol)
                # plot median point points( at[i], med[i], pch=pchMed, col=colMed )
            }
            points(at[i], mean(datas[[i]]), pch = pch.mean, cex = 1.3)
        }
    } else {
        if (!add) {
            plot.window(xlim = ylim, ylim = xlim)
            axis(1)
            axis(2, at = at, label = label)
        }
        
        box()
        for (i in 1:n) {
            # plot left/right density curve
            polygon(c(base[[i]], rev(base[[i]])), c(at[i] - height[[i]], rev(at[i] + 
                height[[i]])), col = col, border = border, lty = lty, lwd = lwd)
            
            if (drawRect) {
                # plot IQR
                boxplot(datas[[i]], yaxt = yaxt, at = at[i], add = TRUE, pars = list(boxwex = 0.8 * 
                  wex, outpch = if (mark.outlier) "" else 1))
                if ((length(outliers[[i]][[1]]) > 0) & mark.outlier) 
                  text(rep(at[i], length(outliers[[i]][[1]])), outliers[[i]][[1]], 
                    labels = outliers[[i]][[2]])
                # lines( at[c( i, i)], c(lower[i], upper[i]) ,lwd=lwd, lty=lty)
            }
            points(at[i], mean(datas[[i]]), pch = pch.mean, cex = 1.3)
        }
    }
    invisible(list(upper = upper, lower = lower, median = med, q1 = q1, q3 = q3))
}

# plot
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5, 
    ylim = c(0.3, 0.6), xlim = c(1, 4), lwd = 2, pch = 5, axes = F, main = " ")
axis(1, at = c(1.5, 2.5, 3.5), labels = c("HF", "LF", "VLF"))
axis(2, pos = 1.1)
mtext("Word Frequency", side = 1, line = 3, cex = 1.5, font = 2)

par(las = 0)
mtext("Group Mean M", side = 2, line = 2.9, cex = 1.5, font = 2)

x <- c(1.5, 2.5, 3.5)

vioplot.singmann(RT.hf.sp, RT.lf.sp, RT.vlf.sp, add = TRUE, mark.outlier = FALSE, 
    at = c(1.5, 2.5, 3.5), wex = 0.4, yaxt = "n")
vioplot.singmann(RT.hf.ac, RT.lf.ac, RT.vlf.ac, add = TRUE, mark.outlier = FALSE, 
    at = c(1.5, 2.5, 3.5), wex = 0.4, col = "grey", border = "grey", rectCol = "grey", 
    colMed = "grey", yaxt = "n")

text(2.5, 0.35, "Speed", cex = 1.4, font = 1, adj = 0.5)
text(2.5, 0.58, "Accuracy", cex = 1.4, font = 1, col = "grey", adj = 0.5)

5.4 Combined Line and Bar Plot

In many psychological experiments, there are two dependent variables for each participant: mean response time (RT) and mean proportion of errors. This plot shows them both – RTs are on the left y-axis, and errors are on the right y-axis.

Show R-Code
### Plot 1: RTs on first y-axis, errors on second y-axis

plotsebargraph = function(loc, value, sterr, wiskwidth, color = "grey", linewidth = 2) {
    w = wiskwidth/2
    segments(x0 = loc, x1 = loc, y0 = value, y1 = value + sterr, col = color, 
        lwd = linewidth)
    segments(x0 = loc - w, x1 = loc + w, y0 = value + sterr, y1 = value + sterr, 
        col = color, lwd = linewidth)  # upper whiskers
}
plotsegraph = function(loc, value, sterr, wiskwidth, color = "grey", linewidth = 2) {
    w = wiskwidth/2
    segments(x0 = loc, x1 = loc, y0 = value - sterr, y1 = value + sterr, col = color, 
        lwd = linewidth)
    segments(x0 = loc - w, x1 = loc + w, y0 = value + sterr, y1 = value + sterr, 
        col = color, lwd = linewidth)  # upper whiskers
    segments(x0 = loc - w, x1 = loc + w, y0 = value - sterr, y1 = value - sterr, 
        col = color, lwd = linewidth)  # lower whiskers
}

# =======================================================

# Data; order = Speed, neutral, accuracy
MRT <- c(429, 515, 555)
MRT.se <- c(25, 25, 30)
Er <- c(0.23, 0.14, 0.13)
Er.se <- c(0.022, 0.021, 0.021)

# ======================================================

par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
# mpg = c(3, 1, 0) is default. first = axis labels!; middle = tick labels mar
# = c(5, 4, 4, 2) + 0.1 is default

digitsize <- 1.2
x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " Mean Response Time (ms.)", 
    xlab = " ", cex = 1.5, ylim = c(200, 800), xlim = c(1, 4), lwd = 2, pch = 5, 
    axes = F, main = " ")

axis(1, at = c(1.5, 2.5, 3.5), labels = c("Speed", "Neutral", "Accuracy"))
mtext("Cue", side = 1, line = 3, cex = 1.5, font = 2)
axis(2, at = c(300, 400, 500, 600, 700))

x = c(1.5, 2.5, 3.5)
points(x, MRT, cex = 1.5, lwd = 2, pch = 19)
plot.errbars = plotsegraph(x, MRT, MRT.se, 0.1, color = "black")  #0.1 = wiskwidth

lines(c(1.5, 2.5, 3.5), MRT, lwd = 2, type = "c")
text(1.5, MRT[1] + 60, "429", adj = 0.5, cex = digitsize)
text(2.5, MRT[2] + 60, "515", adj = 0.5, cex = digitsize)
text(3.5, MRT[3] + 60, "555", adj = 0.5, cex = digitsize)

par(new = TRUE)

x <- c(1, 2, 3, 4)
plot(x, c(-10, -10, -10, -10), type = "p", ylab = " ", xlab = " ", cex = 1.5, 
    ylim = c(0, 1), xlim = c(1, 4), lwd = 2, axes = FALSE, main = " ")
axis(4, at = c(0, 0.1, 0.2, 0.3, 0.4), las = 1)
grid::grid.text("Mean Proportion of Errors", 0.97, 0.5, rot = 270, gp = grid::gpar(cex = 1.5, 
    font = 2))

width <- 0.25
linewidth <- 2
x0 <- 1.5 - width
x1 <- 1.5 + width
y0 <- 0
y1 <- Er[1]
segments(x0, y0, x0, y1, lwd = linewidth)
segments(x0, y1, x1, y1, lwd = linewidth)
segments(x1, y1, x1, y0, lwd = linewidth)
segments(x1, y0, x0, y0, lwd = linewidth)
x0 <- 2.5 - width
x1 <- 2.5 + width
y0 <- 0
y1 <- Er[2]
segments(x0, y0, x0, y1, lwd = linewidth)
segments(x0, y1, x1, y1, lwd = linewidth)
segments(x1, y1, x1, y0, lwd = linewidth)
segments(x1, y0, x0, y0, lwd = linewidth)
x0 <- 3.5 - width
x1 <- 3.5 + width
y0 <- 0
y1 <- Er[3]
segments(x0, y0, x0, y1, lwd = linewidth)
segments(x0, y1, x1, y1, lwd = linewidth)
segments(x1, y1, x1, y0, lwd = linewidth)
segments(x1, y0, x0, y0, lwd = linewidth)

loc.errbars <- c(1.5, 2.5, 3.5)
plot.errbars <- plotsebargraph(loc.errbars, Er, Er.se, 0.2, color = "black")  # 0.2 = wiskwidth

text(1.5, 0.9, "Behavioral Data", font = 2, cex = 2, pos = 4)

text(1.5, 0.05, "0.23", adj = 0.5, cex = digitsize)
text(2.5, 0.05, "0.14", adj = 0.5, cex = digitsize)
text(3.5, 0.05, "0.13", adj = 0.5, cex = digitsize)

6 Bar Plots

Like their histogram cousin, bar plots are intrinsically boring.

6.1 Including Error Bars

The title says it all. Note that the error bars are added with the l_ply function. Courtesy of Helen Steingroever and Quentin Gronau.

Show R-Code
library(plyr)

mean.prop.sw <- c(0.7, 0.6, 0.67, 0.5, 0.45, 0.48, 0.41, 0.34, 0.5, 0.33)
sd.prop.sw <- c(0.3, 0.4, 0.2, 0.35, 0.28, 0.31, 0.29, 0.26, 0.21, 0.23)
N <- 100
b <- barplot(mean.prop.sw, las = 1, xlab = " ", ylab = " ", col = "grey", cex.lab = 1.7, 
    cex.main = 1.5, axes = FALSE, ylim = c(0, 1))

axis(1, c(0.8, 2, 3.2, 4.4, 5.6, 6.8, 8, 9.2, 10.4, 11.6), 1:10, cex.axis = 1.3)
axis(2, seq(0, 0.8, by = 0.2), cex.axis = 1.3, las = 1)
mtext("Block", side = 1, line = 2.5, cex = 1.5, font = 2)
mtext("Proportion of Switches", side = 2, line = 3, cex = 1.5, font = 2)
l_ply(seq_along(b), function(x) arrows(x0 = b[x], y0 = mean.prop.sw[x], x1 = b[x], 
    y1 = mean.prop.sw[x] + 1.96 * sd.prop.sw[x]/sqrt(N), code = 2, length = 0.1, 
    angle = 90, lwd = 1.5))

7 Densities

Densities are ubiquitous, particularly for those who have a predeliction for Bayesian inference. As for the histogram and the bar plot, it is generally a good idea to add more information to the bare-bones plot.

7.1 Standard

This is a relatively standard plot. Note the thickness of the lines and the font size for the axis labels.

Show R-Code
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)

yhigh <- 1
xlow <- -3
xhigh <- 3
postmean <- 0.5
postsd <- 0.8
priormean <- 0
priorsd <- 1

plot(function(x) dnorm(x, mean = postmean, sd = postsd), xlow, xhigh, ylim = c(0, 
    yhigh), xlim = c(xlow, xhigh), lwd = 2, lty = 1, ylab = "", xlab = "", main = "Inference for Mu", 
    axes = FALSE)
lines(c(0, 0), c(0, 1.25), lwd = 2, col = "grey")

par(new = TRUE)

plot(function(x) dnorm(x, mean = priormean, sd = priorsd), xlow, xhigh, ylim = c(0, 
    yhigh), xlim = c(xlow, xhigh), lwd = 2, lty = 2, ylab = "", xlab = "", axes = FALSE)
axis(1)
axis(2)
par(las = 0)
mtext("Mu", side = 1, line = 2.5, cex = 1.5)
mtext("Density", side = 2, line = 3, cex = 1.8)

par(op)

7.2 With a Histogram on Top

This plot adds a histogram to the density plot, but without needlessly displaying the vertical histogram lines as well. In addition, the code defines the extent to which the lines are transparent, so that both the density and the histogram remain visible, and one does not completely block the other from view.

Show R-Code
library(polspline)
Gen.p.within = function(n.draws = 1000, n.data = 20, d = 0, s = 1) {
	
    # Generates p-values from a within-subject (paired) t-test
	
    p <- array(dim = n.draws)
    for (i in 1:n.draws) {
        # yes I know, vectorize is better
        dat <- rnorm(n.data, mean = d, sd = s)
        p[i] <- as.numeric(t.test(dat)$p.value)
    }
    return(p)
}

n.draws <- 20000
n.data <- 20
dfr <- n.data - 1
s <- 1

p.observed <- 0.045
t.observed <- qt(1 - (p.observed/2), dfr)

set.seed(1)
pvalues <- Gen.p.within(n.draws, n.data, d = s * t.observed/sqrt(n.data), s)

par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)

# Start with probit-transformed uniform distribution, that is, N(0,1):
y.high <- 1
x.high <- 4
x.low <- min(qnorm(pvalues))
curve(dnorm(x), from = -4, to = 4, add = FALSE, col = "black", lwd = 2, ylim = c(0, 
    y.high), xlim = c(x.low, x.high), ylab = "Density", xlab = " ", main = " ", 
    axes = FALSE)
axis(1)
axis(2)
mtext("Probit-transformed p Value", side = 1, line = 2.8, cex = 1.5)
greycolhist <- rgb(0, 0, 0, alpha = 0.7)
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 280, maxColorValue = 280)
# For transparent lines set, set 'alpha' between 0 (invisible) and 255
# (opaque)
lines(c(qnorm(p.observed), qnorm(p.observed)), c(0, y.high), lwd = 2, col = greycol)  #at observed p
points(qnorm(p.observed), dnorm(qnorm(p.observed)), pch = 21, cex = 2, bg = "grey")  # height under H0
height.H0 <- dnorm(qnorm(p.observed))

# Now for probit-transformed distribution of p-values under H1:
par(new = TRUE)
Nbreaks <- 20
small.y <- 0.05

y <- hist(qnorm(pvalues), Nbreaks, plot = FALSE)
plot(c(y$breaks, max(y$breaks)), c(0, y$density, 0), col = greycolhist, type = "S", 
    lwd = 2, lty = 1, ylim = c(0, y.high), xlim = c(x.low, x.high), xlab = " ", 
    ylab = "Density", main = " ")
pvalues.denspp <- logspline(qnorm(pvalues))
par(new = TRUE)
plot(pvalues.denspp, xlim = c(x.low, x.high), ylim = c(0, y.high), col = greycol, 
    lwd = 2)
height.H1 <- dlogspline(qnorm(p.observed), pvalues.denspp)  # height under H1
points(qnorm(p.observed), height.H1, pch = 21, cex = 2, bg = "grey")

7.3 Including Text

This plot adds text to the plot. Although this is generally trivial, this particular example contains a mathematical symbol that is tricky to display properly (unless, of course, you know how it works).

Show R-Code
NormBF10 <- function(dat, mu = 0, m = 1, priordat = NULL, plot = F, xwide = 3) {
	
    # dat ~ N(theta,1); theta ~ N(mu, 1/m); mu is prior mean, m is prior precision
    if (is.null(priordat)) {
        # no prior data
        priormean <- mu
        priorprec <- m
    }
    if (!is.null(priordat)) {
        # prior data
        n <- length(priordat)
        priormean <- (m * mu + n * mean(priordat))/(m + n)
        priorprec <- m + n
    }
    n <- length(dat)
    posteriormean <- (priorprec * priormean + n * mean(dat))/(priorprec + n)
    posteriorprec <- priorprec + n
    
    prior.height <- dnorm(0, mean = priormean, sd = priorprec^(-0.5))
    posterior.height <- dnorm(0, mean = posteriormean, sd = posteriorprec^(-0.5))
    BF10 <- prior.height/posterior.height
    if (plot == TRUE) {
        par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
            font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
        yhigh <- 1.5
        xlow <- -3
        xhigh <- 3
        plot(function(x) dnorm(x, mean = posteriormean, sd = posteriorprec^(-0.5)), 
            xlow, xhigh, ylim = c(0, yhigh), xlim = c(xlow, xhigh), lwd = 2, 
            lty = 1, ylab = "", xlab = "", axes = FALSE)
        lines(c(0, 0), c(0, 1.25), lwd = 2, col = "grey")
        par(new = TRUE)
        plot(function(x) dnorm(x, mean = priormean, sd = priorprec^(-0.5)), xlow, 
            xhigh, ylim = c(0, yhigh), xlim = c(xlow, xhigh), lwd = 2, lty = 2, 
            ylab = "", xlab = "", axes = FALSE)
        axis(1)
        axis(2)
        par(las = 0)
        mtext("Mu", side = 1, line = 2.5, cex = 1.5)
        mtext("Density", side = 2, line = 3, cex = 1.8)
        # Show Savage-Dickey density ratio:
        points(0, prior.height, cex = 2, pch = 21, bg = "grey")
        points(0, posterior.height, cex = 2, pch = 21, bg = "grey")
    }
    invisible(BF10)
}
dat <- c(0, 1, -1)
# dat <- c(-1,1,0)

#### simultaneous #### 1/NormBF10(dat, plot = TRUE) #2 text(-3, 1.4,
#### expression(BF[0][1](y[1],y[2],y[3]) == 2), cex = 1.5, pos = 4)

##### y1 #### 1/NormBF10(dat = dat[1], plot = TRUE) #sqrt(2) text(-3, 1.4,
##### expression(BF[0][1](y[1]) == sqrt(2)), cex = 1.5, pos = 4)

##### y2, given y1 #### 1/NormBF10(dat = dat[2], plot = TRUE, priordat = dat[1]) #1.04
##### composite.expression <- expression(paste(BF[0][1], '(', y[2], ' | ', y[1],
##### ')' %~~% 1.04)) text(-3, 1.4, composite.expression, cex = 1.5, pos = 4)

##### y3, given y1 and y2 ####
BF01 <- 1/NormBF10(dat = dat[3], plot = TRUE, priordat = dat[1:2])  #1.36
composite.expression <- expression(paste(BF[0][1], "(", y[3], " | ", y[1], ",", 
    y[2], ")" %~~% 1.36))
text(-3, 1.4, composite.expression, cex = 1.5, pos = 4)

7.4 Another Example

This is another example, featuring a nice Greek letter. Seriously, what is important here is that the labels are positioned next to the associated graphical element. This approach is more direct than creating a legend, when the reader has to decode the legend first, keep the symbols in working memory, and then turn attention to the graph itself. Bottom line: only use legends when you have to. Even then, you may find that the legend box almost never fulfills a useful function, and can safely be omitted.

Show R-Code
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)

yhigh <- 3
xi <- c(1, 0.5, 0.1)
plot(function(x) dbeta(x, xi[1], 1), 0, 1, ylim = c(0, yhigh), xlim = c(0, 1), 
    lwd = 2, lty = 1, xlab = " ", ylab = " ")
mtext("p value", 1, line = 2.5, cex = 1.5, font = 2)
mtext("Density", 2, line = 3, cex = 1.5, font = 2, las = 0)

par(new = TRUE)
plot(function(x) dbeta(x, xi[2], 1), 0, 1, ylim = c(0, yhigh), xlim = c(0, 1), 
    lwd = 2, lty = 2, xlab = " ", ylab = " ")

par(new = TRUE)
plot(function(x) dbeta(x, xi[3], 1), 0, 1, ylim = c(0, yhigh), xlim = c(0, 1), 
    lwd = 2, lty = 3, xlab = " ", ylab = " ")

cexsize <- 1.5
text(0.5, 1.15, expression(xi == 1(i.e., H[0])), cex = cexsize, pos = 4)
text(0.1, 1.6, expression(xi == 0.5), cex = cexsize, pos = 4)
text(0, 0.2, expression(xi == 0.1), cex = cexsize, pos = 4)

7.5 Highlighting Specific Areas

It is cool to be able to highlight specific parts of a density by some color coding scheme. In this example, Ravi Selker shows how that can be done (hint: it’s the polygon function).

Show R-Code
x <- seq(0, 1, 0.001)
y <- dbeta(x, 2, 4)

y1 <- 0.25
y2 <- 0.62

par(cex.main = 2, mar = c(4, 2, 4, 2) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 2, 
    font.lab = 2, cex.axis = 2, bty = "n", las = 1, lwd = 3)

layout(matrix(c(1, 2), 1, 2))

########################################################## UNBIASED THRESHOLDS ######

plot(x, y, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "Unbiased Thresholds", bty = "n", yaxt = "n", xaxt = "n", xpd = FALSE)
polygon(c(x[which(x < 0.2)], 0.2, 0), c(y[which(x < 0.2)], 0, 0), col = "#E0E0E0", 
    xpd = FALSE)
polygon(c(x[which(x >= 0.2 & x < 0.4)], 0.4, 0.2), c(y[which(x >= 0.2 & x < 0.4)], 
    0, 0), col = "#C0C0C0", xpd = FALSE)
polygon(c(x[which(x >= 0.4 & x < 0.6)], 0.6, 0.4), c(y[which(x >= 0.4 & x < 0.6)], 
    0, 0), col = "#A0A0A0", xpd = FALSE)
polygon(c(x[which(x >= 0.6 & x < 0.8)], 0.8, 0.6), c(y[which(x >= 0.6 & x < 0.8)], 
    0, 0), col = "#808080", xpd = FALSE)
polygon(c(x[which(x >= 0.8)], 1, 0.8), c(y[which(x >= 0.8)], 0, 0), col = "#606060", 
    xpd = FALSE)
axis(1, c(0, 1), c("0", "1"), lwd = 0, cex = 2, pos = -0.09)
abline(v = 0)
abline(v = 1)
l <- seq(0, 3.2, 0.01)
x1 <- rep(0.2, length(l))
par(new = TRUE)
plot(x1, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
x2 <- rep(0.4, length(l))
par(new = TRUE)
plot(x2, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
x3 <- rep(0.6, length(l))
par(new = TRUE)
plot(x3, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
x4 <- rep(0.8, length(l))
par(new = TRUE)
plot(x4, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
text(0.2, 3.4, expression(gamma[1]), cex = 2)
text(0.4, 3.4, expression(gamma[2]), cex = 2)
text(0.6, 3.4, expression(gamma[3]), cex = 2)
text(0.8, 3.4, expression(gamma[4]), cex = 2)
text(0.1, 2.6, "1", cex = 2)
text(0.3, 2.6, "2", cex = 2)
text(0.5, 2.6, "3", cex = 2)
text(0.7, 2.6, "4", cex = 2)
text(0.9, 2.6, "5", cex = 2)

########################################################## BIASED THRESHOLDS ######

a <- 0.75  #scaling parameter
b <- 1.5  #shifting parameter
thr_1 <- (b * (0.2^a))/((1 - 0.2)^a + b * (0.2^a))
thr_2 <- (b * (0.4^a))/((1 - 0.4)^a + b * (0.4^a))
thr_3 <- (b * (0.6^a))/((1 - 0.6)^a + b * (0.6^a))
thr_4 <- (b * (0.8^a))/((1 - 0.8)^a + b * (0.8^a))

plot(x, y, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "Biased Thresholds", bty = "n", yaxt = "n", xaxt = "n", xpd = FALSE)
polygon(c(x[which(x < thr_1)], thr_1, 0), c(y[which(x < thr_1)], 0, 0), col = "#E0E0E0", 
    xpd = FALSE)
polygon(c(x[which(x >= thr_1 & x < thr_2)], thr_2, thr_1), c(y[which(x >= thr_1 & 
    x < thr_2)], 0, 0), col = "#C0C0C0", xpd = FALSE)
polygon(c(x[which(x >= thr_2 & x < thr_3)], thr_3, thr_2), c(y[which(x >= thr_2 & 
    x < thr_3)], 0, 0), col = "#A0A0A0", xpd = FALSE)
polygon(c(x[which(x >= thr_3 & x < thr_4)], thr_4, thr_3), c(y[which(x >= thr_3 & 
    x < thr_4)], 0, 0), col = "#808080", xpd = FALSE)
polygon(c(x[which(x >= thr_4)], 1, thr_4), c(y[which(x >= thr_4)], 0, 0), col = "#606060", 
    xpd = FALSE)
axis(1, c(0, 1), c("0", "1"), lwd = 0, cex = 2, pos = -0.09)
abline(v = 0)
abline(v = 1)
l <- seq(0, 3.2, 0.01)
x1 <- rep(thr_1, length(l))
par(new = TRUE)
plot(x1, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
x2 <- rep(thr_2, length(l))
par(new = TRUE)
plot(x2, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
x3 <- rep(thr_3, length(l))
par(new = TRUE)
plot(x3, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
x4 <- rep(thr_4, length(l))
par(new = TRUE)
plot(x4, l, type = "l", ylim = c(0, 3.5), xlim = c(0, 1), xlab = "", ylab = "", 
    main = "", bty = "n", yaxt = "n", xaxt = "n")
text(thr_1, 3.4, expression(delta[i1]), cex = 2)
text(thr_2, 3.4, expression(delta[i2]), cex = 2)
text(thr_3, 3.4, expression(delta[i3]), cex = 2)
text(thr_4, 3.4, expression(delta[i4]), cex = 2)
text(thr_1/2, 2.6, "1", cex = 2)
text((thr_1 + thr_2)/2, 2.6, "2", cex = 2)
text((thr_2 + thr_3)/2, 2.6, "3", cex = 2)
text((thr_3 + thr_4)/2, 2.6, "4", cex = 2)
text((thr_4 + 1)/2, 2.6, "5", cex = 2)

7.6 More Highlighting of Specific Areas

Mijke Rhemtulla also likes to highlight specific parts of a density. This is the first plot in a series, taken from one of Mijke’s stats courses.

Show R-Code
xbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)

muH0 <- 0
muH1 <- 8

t0 <- (xdiff - muH0)/sdiff

# H0 distribution with p-value shaded:
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
par(mar = c(4, 4.5, 4.5, 1))

x <- seq(-15, 15, by = 0.001)
y <- dt(x/sdiff, df = 28)
plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 20), 
    lwd = 2)
axis(side = 1, at = seq(-15, 15, by = 5), pos = 0, lwd = 2)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2)

# shade area to right of obtained test statistic:
t0 <- xdiff/sdiff
cord.x <- c(t0, seq(t0, 4, 0.001), 4) * sdiff
cord.y <- c(0, dt(seq(t0, 4, 0.001), df = 28), 0)
polygon(cord.x, cord.y, col = "grey")
cord.x <- c(-4, seq(-4, -t0, 0.001), -t0) * sdiff
cord.y <- c(0, dt(seq(-4, -t0, 0.001), df = 24), 0)
polygon(cord.x, cord.y, col = "grey")

# add lines and text:
abline(v = xdiff, col = "red4", lwd = 2)
text(-15, 0.25, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")), adj = 0, 
    cex = 1.8)
text(10, 0.08, paste("p = .04"), adj = 0, col = "red4", cex = 1.8)
lines(c(10, 8), c(0.05, 0.01), col = "red4", lwd = 2)
lines(c(10, -8), c(0.05, 0.01), col = "red4", lwd = 2)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4", 
    cex = 1.8)

7.7 Still More Highlighting

Part 2…

Show R-Code
xbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)

muH0 <- 0
muH1 <- 8

t0 <- (xdiff - muH0)/sdiff
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)

x <- seq(-15, 30, by = 0.001)
y <- dt(x/sdiff, df = 28)
y3 <- dt((x - 9)/sdiff, df = 28)
plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 30), 
    lwd = 2)
lines(x, y3, lwd = 2)
axis(side = 1, at = seq(-15, 30, by = 5), labels = seq(-15, 30, by = 5), cex.axis = 1.6, 
    lwd = 2)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2, cex.axis = 1.6, 
    padj = 0.6)

# shade critical regions:
tcrit <- qt(0.975, df = 28)
cord.x <- c(tcrit, seq(tcrit, 4, 0.001), 4) * sdiff
cord.y <- c(0, dt(seq(tcrit, 4, 0.001), df = 28), 0)
polygon(cord.x, cord.y, col = "grey")
cord.x <- c(-4, seq(-4, -tcrit, 0.001), -tcrit) * sdiff
cord.y <- c(0, dt(seq(-4, -tcrit, 0.001), df = 24), 0)
polygon(cord.x, cord.y, col = "grey")

# shade type-II error region
xcrit <- tcrit * sdiff
cord.x <- c(-5, seq(-5, xcrit, 0.001), xcrit)
cord.y <- c(0, dt(((seq(-5, xcrit, 0.001) - 9)/sdiff), df = 28), 0)
polygon(cord.x, cord.y, col = "grey90")

# add lines and text:
abline(v = xdiff, col = "red4", lwd = 2)
text(-16.3, 0.3, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")), 
    adj = 0, cex = 1.8)
text(13, 0.3, expression(paste(H[1], " : ", mu[diff], "" >= 9, , sep = "")), 
    adj = 0, cex = 1.8)
text(10, 0.08, expression(paste(alpha)), adj = 0, col = "red4", cex = 1.8)
text(-11, 0.08, expression(paste(alpha)), adj = 0, col = "red4", cex = 1.8)
text(1, 0.08, expression(paste(beta)), adj = 0, col = "red4", cex = 1.8)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4", 
    cex = 1.8, padj = 0.4)
lines(c(10, 8), c(0.05, 0.01), col = "red4", lwd = 2)
lines(c(-10, -8), c(0.05, 0.01), col = "red4", lwd = 2)
lines(c(2, 4), c(0.05, 0.01), col = "red4", lwd = 2)

7.8 Density Ratios

Part 3…

Show R-Code
xbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)

muH0 <- 0
muH1 <- 8

t0 <- (xdiff - muH0)/sdiff
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
par(mar = c(4, 4.5, 4.5, 1))
x <- seq(-15, 30, by = 0.001)
y <- dt(x/sdiff, df = 28)
y3 <- dt((x - 9)/sdiff, df = 28)

plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 25), 
    lwd = 2)
lines(x, y3, lwd = 2)
axis(side = 1, at = seq(-15, 30, by = 5), pos = 0, lwd = 2, cex.axis = 1.7)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2, padj = 0.1)
abline(v = xdiff, col = "red4", lwd = 2)
L0 <- dt((xdiff/sdiff), df = 28)
L2 <- dt(((xdiff - 9)/sdiff), df = 28)
lines(c(6.7, 7.3), y = rep(L0, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L2, 2), col = "red4", lwd = 2)
text(8, L0, expression(paste(italic("L"), " = .04")), adj = 0, col = "red4", 
    cex = 1.8)
text(7.5, L2, expression(paste(italic("L"), " = .32")), adj = 0, col = "red4", 
    cex = 1.8)
text(-16, 0.35, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")), adj = 0, 
    cex = 1.8)
text(-16, 0.3, expression(paste(H[1], " : ", mu[diff], " = 9", sep = "")), adj = 0, 
    cex = 1.8)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4", 
    cex = 1.8, padj = 0.1)
text(14, 0.2, expression(paste("LR = ", frac(".32", ".04") %~~% 8, sep = "")), 
    adj = 0, col = "red4", cex = 1.8)

7.9 Many Density Ratios

Part 4… The take-home message from the last set of plots: use polygon, annotate the plot, and use large font sizes and thick graphical elements.

Show R-Code
xbar.therapy <- 92
s.therapy <- 8.5
xbar.placebo <- 85
s.placebo <- 9.1
n <- 15
xdiff <- xbar.therapy - xbar.placebo
sdiff <- sqrt((s.therapy^2 + s.placebo^2)/2) * sqrt(2/n)
sdiff <- sqrt(s.therapy^2 + s.placebo^2)/sqrt(n)

muH0 <- 0
muH1 <- 8

t0 <- (xdiff - muH0)/sdiff
par(cex.main = 1.5, mar = c(4, 4.5, 4.5, 1), mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
par(mar = c(4, 4.5, 4.5, 1))

# Bayes Factor (or, ugliest code ever and I DO NOT CARE TO FIX IT)
x <- seq(-15, 30, by = 0.001)
y <- dt(x/sdiff, df = 28)

y1 <- dt((x - 1)/sdiff, df = 28)
y2 <- dt((x - 2)/sdiff, df = 28)
y3 <- dt((x - 3)/sdiff, df = 28)
y4 <- dt((x - 4)/sdiff, df = 28)
y5 <- dt((x - 5)/sdiff, df = 28)
y6 <- dt((x - 6)/sdiff, df = 28)
y7 <- dt((x - 7)/sdiff, df = 28)
y8 <- dt((x - 8)/sdiff, df = 28)
y9 <- dt((x - 9)/sdiff, df = 28)
y10 <- dt((x - 10)/sdiff, df = 28)

plot(x, y, type = "l", axes = FALSE, xlab = NA, ylab = NA, xlim = c(-15, 25), 
    lwd = 2)

lines(x, y1, col = "grey70")
lines(x, y2, col = "grey70")
lines(x, y3, col = "grey70", lwd = 2)
lines(x, y4, col = "grey70")
lines(x, y5, col = "grey70", lwd = 2)
lines(x, y6, col = "grey70")
lines(x, y7, col = "grey70")
lines(x, y8, col = "grey70", lwd = 2)
lines(x, y9, col = "grey70")
lines(x, y10, col = "grey70", lwd = 2)

axis(side = 1, at = seq(-15, 30, by = 5), pos = 0, lwd = 2, cex.axis = 1.7)
axis(side = 1, at = 7, pos = 0, col = "red4", col.axis = "red4", lwd = 2, padj = 0.1)
abline(v = xdiff, col = "red4", lwd = 2)

L0 <- dt((xdiff/sdiff), df = 28)
L1 <- dt(((xdiff - 1)/sdiff), df = 28)
L2 <- dt(((xdiff - 2)/sdiff), df = 28)
L3 <- dt(((xdiff - 3)/sdiff), df = 28)
L4 <- dt(((xdiff - 4)/sdiff), df = 28)
L5 <- dt(((xdiff - 5)/sdiff), df = 28)
L6 <- dt(((xdiff - 6)/sdiff), df = 28)
L7 <- dt(((xdiff - 7)/sdiff), df = 28)
L8 <- dt(((xdiff - 8)/sdiff), df = 28)
L9 <- dt(((xdiff - 9)/sdiff), df = 28)
L10 <- dt(((xdiff - 10)/sdiff), df = 28)

lines(c(6.7, 7.3), y = rep(L0, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L1, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L2, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L3, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L4, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L5, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L6, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L7, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L8, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L9, 2), col = "red4", lwd = 2)
lines(c(6.7, 7.3), y = rep(L10, 2), col = "red4", lwd = 2)

text(-16.8, 0.35, expression(paste(H[0], " : ", mu[diff], " = 0", sep = "")), 
    adj = 0, cex = 1.6)
text(-16.8, 0.3, expression(paste(H[1], " : 0", "" <= mu[diff], "" <= 10), sep = ""), 
    adj = 0, cex = 1.6)
text(15, 0.35, expression(paste(italic("L"), "(", H[0], ") = .04")), adj = 0, 
    col = "red4", cex = 1.6)
text(15, 0.3, expression(paste(italic("L"), "(", H[1], ") = .10")), adj = 0, 
    col = "red4", cex = 1.6)
text(14.2, 0.22, expression(paste("BF = ", frac(".10", ".04"), " = ", 2.5, sep = "")), 
    adj = 0, col = "red4", cex = 1.6)
mtext(expression(bar(x)[diff]), side = 1, line = 2, at = 6.5, adj = 0, col = "red4", 
    cex = 1.8, padj = 0.1)

7.10 Stacked Densities

Michael Lee attended me to a “stacked densities plot” [http://nxn.se/post/97650612370/high-contrast-stacked-distribution-plots]. Quentin Gronau did the work and shows how multiple densities can be displayed at the same time, while still being discriminable. Note the use of the trans3d function.

Show R-Code
op <- par(mar = c(4, 0, 0, 4))

x <- seq(-12, 12, 0.1)
x.ticks <- seq(-12, 12, 2)
y <- x
z <- matrix(0, ncol = length(x), nrow = length(y))
z[, 1] <- dnorm(x)
zcol <- matrix(0, ncol = length(x), nrow = length(y))
zcol[, 1] <- "black"

res <- persp(x, y, z, theta = 0, phi = 0, expand = 0.4, xlab = "", ylab = "", 
    ticktype = "detailed", cex.lab = 0.8, zlab = "", box = FALSE, border = FALSE, 
    xlim = c(-13, 13))
polygon(trans3d(c(x, rev(x)), y = rep(y[1], 2 * length(x)), z = c(dnorm(y, 3.8, 
    2), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, blue = 190, 
    alpha = 100, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[41], 2 * length(x)), z = c(dnorm(y, 6.8), 
    rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, blue = 190, 
    alpha = 140, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[81], 2 * length(x)), z = c(dnorm(y, -1, 
    2.5), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, 
    blue = 190, alpha = 180, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[121], 2 * length(x)), z = c(dnorm(y, 
    -5), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, blue = 190, 
    alpha = 220, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[161], 2 * length(x)), z = c(dnorm(y, 
    2.5, 1.5), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, 
    blue = 190, alpha = 260, maxColorValue = 300), border = NA)
polygon(trans3d(c(x, rev(x)), y = rep(y[201], 2 * length(x)), z = c(dnorm(y, 
    -9, 0.8), rep(0, length(x))), pmat = res), col = rgb(red = 190, green = 190, 
    blue = 190, alpha = 300, maxColorValue = 300), border = NA)

### draw x-axis
lines(trans3d(x[which(x == -8):which(x == 10)], min(y) - 2, min(z), res), col = "black", 
    lwd = 1.4)

# tick marks
tick.start <- trans3d(seq(-8, 10, 2), min(y) - 2, min(z), res)
tick.end <- trans3d(seq(-8, 10, 2), min(y) - 2, min(z - 0.01), res)
segments(tick.start$x, tick.start$y, tick.end$x, tick.end$y, lwd = 2.6)

# labels
labels <- seq(-8, -2, 2)
label.pos <- trans3d(seq(-8, -2, 2), min(y) - 2, min(z - 0.035), res)
text(label.pos$x, label.pos$y, labels = labels, cex = 1.6, adj = 0.65)
labels <- seq(0, 10, 2)
label.pos <- trans3d(seq(0, 10, 2), min(y) - 2, min(z - 0.035), res)
text(label.pos$x, label.pos$y, labels = labels, cex = 1.6, adj = 0.5)

### add labels to distributions
text(trans3d(3.8, y[1], dnorm(3.8, 3.8, 2) + 0.02, res), "a", cex = 1.7)
text(trans3d(6.8, y[41], dnorm(6.8, 6.8) + 0.024, res), "b", cex = 1.7)
text(trans3d(-1, y[81], dnorm(-1, -1, 2.5) + 0.027, res), "c", cex = 1.7)
text(trans3d(-5, y[121], dnorm(-5, -5) + 0.029, res), "d", cex = 1.7)
text(trans3d(2.5, y[161], dnorm(2.5, 2.5, 1.5) + 0.033, res), "e", cex = 1.7)
text(trans3d(-9, y[201], dnorm(-9, -9, 0.8) + 0.039, res), "f", cex = 1.7)

par(op)

8 Functions

It can be very informative to plot a function. This is relatively straightforward once you stick to the basic principles (thick lines, annotate the plot, large font sizes).

8.1 Plotting a Function

What did we say? Thick lines, annotate the plot, large font sizes!

Show R-Code
Max.BF10 = function(p) {
    # Computes the upper bound on the Bayes factor As in Sellke, Bayarri, &
    # Berger, 2001
    Max.BF10 <- -1/(exp(1) * p * log(p))
    return(Max.BF10)
}

# Plot this function for p in .001 to .1
xlow <- 0.001
xhigh <- 0.1
p1 <- 0.0373
p2 <- 0.00752
p3 <- 0.001968
par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(function(p) Max.BF10(p), xlow, xhigh, xlim = c(xlow, xhigh), lwd = 2, xlab = " ", 
    ylab = " ")
mtext("Two-sided p value", 1, line = 2.5, cex = 1.5, font = 2)
mtext("Maximum Bayes factor for H1", 2, line = 2.8, cex = 1.5, font = 2, las = 0)
lines(c(0, p1), c(3, 3), lwd = 2, col = "grey")
lines(c(0, p2), c(10, 10), lwd = 2, col = "grey")
lines(c(0, p3), c(30, 30), lwd = 2, col = "grey")
lines(c(p1, p1), c(0, 3), lwd = 2, col = "grey")
lines(c(p2, p2), c(0, 10), lwd = 2, col = "grey")
lines(c(p3, p3), c(0, 30), lwd = 2, col = "grey")

cexsize <- 1.2
text(0.005, 31, expression(max((BF[10])) == 30 %<->% p %~~% 0.002), cex = cexsize, 
    pos = 4)
text(0.01, 11, expression(max((BF[10])) == 10 %<->% p %~~% 0.008), cex = cexsize, 
    pos = 4)
text(p1 - 0.005, 5, expression(max((BF[10])) == 3 %<->% p %~~% 0.037), cex = cexsize, 
    pos = 4)

9 Time Series

What’s not to love about time series? In constrast to some of the previous plots, time series are virtually always interesting, almost mesmerizing. The bar plot compares to a time series as, well, a refrigerator compares to Marilin Monroe. The reason, of course, is that time series are highly informative: they usually contain many observations; moreover, they show how particular variables change over time (it is a time series, after all). Enough of the talking – let’s turn to some examples.

9.1 A Diffusion Process

Instead of giving a lecture about diffusion processes, I’ll point out that the lines are transparent. We’ve encountered this before but it was Guy Hawkins who showed me how to do this in R.

Show R-Code
gendat = function(ndat = 1000, dt = 0.1) {
    # Outputs a sequence of Brownian motion data
    dat <- array()
    dat[1] <- rnorm(1, mean = 0, sd = sqrt(dt))
    
    for (j in 1:(ndat - 1)) {
        drift <- 0
        diffvar <- 1
        
        error <- rnorm(1, 0, sqrt(diffvar * dt))
        dat[j + 1] <- dat[j] + drift * dt + error  # Cobb & Zacks (1985), Eq. 1.14
    }
    
    invisible(dat)  # same as 'return', but without printing to console    
}

## General settings:
dt <- 0.1
ntime <- 1000
times <- c(1:ntime)
nsims <- 1000

# Plot settings:
ylow <- -40
yhigh <- 40
xhigh <- 1.3 * ntime
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 170, maxColorValue = 255)
# For transparent lines set, set 'alpha' between 0 (invisible) and 255
# (opaque)

op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
plot(times, gendat(ndat = ntime, dt), type = "l", lwd = 1, main = "", ylab = "", 
    xlab = "", axes = FALSE, ylim = c(ylow, yhigh), xlim = c(0, xhigh), cex.lab = 1, 
    font.lab = 2, cex.axis = 0.9, col = greycol, bty = "n")
axis(1, at = c(0, 200, 400, 600, 800, 1000), lab = c("0", "20", "40", "60", "80", 
    "100"))
# NB the labels are divided by 10 because dt = .1
axis(2)
par(las = 0)
mtext("Time", side = 1, line = 2.5, cex = 1.5, at = 500)
mtext("Evidence", side = 2, line = 2.8, cex = 1.5)
lines(c(1, ntime), c(0, 0), lwd = 1, lty = 2, col = "black")

for (i in 1:9) {
    par(new = TRUE)
    plot(times, gendat(ndat = ntime, dt), type = "l", lwd = 1, main = "", ylab = "", 
        xlab = "", axes = FALSE, ylim = c(ylow, yhigh), xlim = c(0, xhigh), cex.lab = 1, 
        font.lab = 2, cex.axis = 0.9, col = greycol, bty = "n")
}

std <- sqrt(ntime * dt)
c <- 7000  # A multiplication factor so the Normal density is visible
df1 <- data.frame(yval = seq(from = -35, to = 35, by = 0.1), xval = (dnorm(seq(from = -35, 
    to = 35, by = 0.1), 0, std) * c))
with(df1, lines(xval + ntime + 20, yval, lwd = 2))

# Optional: Check by simulation and plot density estimate
do.sim <- FALSE
if (do.sim == TRUE) {
    x <- array()
    for (i in 1:nsims) {
        x[i] <- gendat(ntime, dt)[ntime]  # end point of simulation process
    }
    startx <- ntime + 20
    yhigh.c <- yhigh * c
    y <- density(x)
    lines((y$y * c) + startx, y$x, lwd = 2, col = greycol)
}

par(op)

9.2 A Sequence of Choices

Helen Steingroever returns to us once again, this time with a choice profile for the Iowa gambling task. The plot conveys a lot of information: for one participant, the plot indicates the sequence of 100 choices among four choice alternatives, and whether or not each choice resulted in a win or a loss.

Show R-Code
# rm(list = ls())

IndividualPerformance <- function(choice, lo, show.losses = FALSE) {
    # Plots the choice profile Args: choice: A vector containing the choices on
    # each trial lo: A vector containing the losses on each trial show.losses:
    # logical: Should the losses be indicated by filled dots?
    
    par(mar = c(4, 4.5, 0.5, 1))
    plot(choice, type = "b", axes = FALSE, xlab = "Trial", ylab = "Deck", cex.lab = 2)
    axis(1, seq(0, 100, length = 6), cex.axis = 1.8)
    axis(2, 1:4, labels = c("A", "B", "C", "D"), cex.axis = 1.8, las = 1)
    if (show.losses == TRUE) {
        index.losses <- which(lo < 0)
        points(matrix(c(index.losses, choice[index.losses]), byrow = FALSE, nrow = length(index.losses)), 
            pch = 19, lwd = 1.5)
    }
}

# Synthetic data
choice <- sample(1:4, 100, replace = TRUE)
lo <- sample(c(-1250, -250, -50, 0), 100, replace = TRUE)

# postscript('DiversePerformance.eps', width = 7, height = 7)
IndividualPerformance(choice, lo, show.losses = TRUE)
# dev.off()

9.3 The Electoral Advantage of Being Tall Revisited

This plot shows the development of the Bayes factor (y-axis) as the data accumulate (x-axis). This procedure may give frequentists a heart attack but, in Bayes world, that’s just how we roll. What we like about the graph are the annotations on the right side of the plot, and the subtle horizontal lines that indicate Jeffreys’ criteria on the evidence. It took some time to figure out how to display the word “Evidence” in its current direction. To make this plot we “borrowed” code from Ruud Wetzels and Benjamin Scheibehenne.

Show R-Code
# rm(list=ls())

# height of president divided by height of most successful opponent:
height.ratio <- c(0.924324324, 1.081871345, 1, 0.971098266, 1.029761905, 
    0.935135135, 0.994252874, 0.908163265, 1.045714286, 1.18404908, 1.115606936, 
    0.971910112, 0.97752809, 0.978609626, 1, 0.933333333, 1.071428571, 
    0.944444444, 0.944444444, 1.017142857, 1.011111111, 1.011235955, 1.011235955, 
    1.089285714, 0.988888889, 1.011111111, 1.032967033, 1.044444444, 1, 
    1.086705202, 1.011560694, 1.005617978, 1.005617978, 1.005494505, 1.072222222, 
    1.011111111, 0.983783784, 0.967213115, 1.04519774, 1.027777778, 1.086705202, 
    1, 1.005347594, 0.983783784, 0.943005181, 1.057142857)

# proportion popular vote for president vs most successful opponent
pop.vote <- c(0.427780852, 0.56148981, 0.597141922, 0.581254292, 0.530344067, 
    0.507425996, 0.526679292, 0.536690951, 0.577825976, 0.573225387, 0.550410082, 
    0.559380032, 0.484823958, 0.500466176, 0.502934212, 0.49569636, 0.516904414, 
    0.522050547, 0.531494442, 0.60014892, 0.545079801, 0.604274986, 0.51635906, 
    0.63850958, 0.652184407, 0.587920412, 0.5914898, 0.624614752, 0.550040193, 
    0.537771958, 0.523673642, 0.554517134, 0.577511576, 0.500856251, 0.613444534, 
    0.504063153, 0.617883695, 0.51049949, 0.553073235, 0.59166415, 0.538982024, 
    0.53455133, 0.547304058, 0.497350649, 0.512424242, 0.536914796)

## now calculate BF sequentially; two-sided test
library("hypergeo")
BF10.HG.exact = function(n, r) {
    # Jeffreys' test for whether a correlation is zero or not Jeffreys
    # (1961), pp. 289-292 Note that if the means are subtracted, n needs to
    # be replaced by n-1
    hypgeo = hypergeo((0.25 + n/2), (-0.25 + n/2), (3/2 + n/2), r^2)
    BF10 = (sqrt(pi) * gamma(n/2 + 1) * (hypgeo))/(2 * gamma(3/2 + n/2))
    return(as.numeric(BF10))
}

BF10 <- array()
BF10[1] <- 1
BF10[2] <- 1

for (i in 3:length(height.ratio)) {
    BF10[i] <- BF10.HG.exact(n = i - 1, r = cor(height.ratio[1:i], pop.vote[1:i]))
}

# We wish to plot this Bayes factor sequentially, as it unfolds as more
# elections become available: ============ Plot log Bayes factors ================

par(cex.main = 1.3, mar = c(4.5, 6, 4, 7) + 0.1, mgp = c(3, 1, 0), cex.lab = 1.3, 
    font.lab = 2, cex.axis = 1.3, las = 1)
xhigh <- 60
plot(log(BF10), xlim = c(1, xhigh), ylim = c(-1 * log(200), log(200)), 
    xlab = "", ylab = "", cex.lab = 1.3, cex.axis = 1.3, las = 1, yaxt = "n", 
    bty = "n", type = "p", pch = 21, bg = "grey")

labelsUpper = log(c(100, 30, 10, 3, 1))
labelsLower = -1 * labelsUpper
criticalP = c(labelsLower, 0, labelsUpper)
for (idx in 1:length(criticalP)) {
    abline(h = criticalP[idx], col = "darkgrey", lwd = 1, lty = 2)
}
abline(h = 0)
axis(side = 4, at = criticalP, tick = TRUE, las = 2, cex.axis = 1, labels = FALSE)
axis(side = 4, at = labelsUpper + 0.602, tick = FALSE, cex.axis = 1, labels = c("Extreme", 
    "Very strong", "Strong", "Moderate", "Anecdotal"))
axis(side = 4, at = labelsLower - 0.602, tick = FALSE, cex.axis = 1, labels = c("Extreme", 
    "Very strong", "Strong", "Moderate", "Anecdotal"))

axis(side = 2, at = c(criticalP), tick = TRUE, las = 2, cex.axis = 1, labels = c("1/100", 
    "1/30", "1/10", "1/3", "1", "", "100", "30", "10", "3", ""))

mtext(expression(BF[1][0]), side = 2, line = 2.5, las = 0, cex = 1.3)
grid::grid.text("Evidence", 0.97, 0.5, rot = 270, gp = grid::gpar(cex = 1.3))
mtext("No. of Elections", side = 1, line = 2.5, las = 1, cex = 1.3)

arrows(20, -log(10), 20, -log(100), length = 0.25, angle = 30, code = 2, 
    lwd = 2)
arrows(20, log(10), 20, log(100), length = 0.25, angle = 30, code = 2, 
    lwd = 2)
text(25, -log(70), "Evidence for H0", pos = 4, cex = 1.3)
text(25, log(70), "Evidence for H1", pos = 4, cex = 1.3)

9.4 A Sequential Test on π

And again the Bayesians flaunt their disdain for the sillyness of sampling plans. The plot below shows the development of the Bayes factor (y-axis) with the number of digits from π. As the digits accumulate, so does the evidence in favor of the null hypothesis (yes frequentists, you read that right – evidence in favor of the null hypothesis).

The plot shows the maximum evidence (in red), the actual evidence (for two different priors), and the area that we can expect the Bayes factor be in 95% of the cases, should the null hypothesis hold. This is dirty frequentist reasoning of course, but the plot does show how it is possible to reject a null hypothesis even when the data provide a lot of support in its favor (i.e., the Jeffreys-Lindley paradox). Courtesy of Quentin Gronau.

Show R-Code
library(plotrix)

### plot multinomial BF

load("BFMultiPi.rda")
load("maxBFMultiPi.rda")
load("exBFMultiPi.rda")

N <- seq(1000, 1e+08, 1000)

par(cex.main = 1.3, mar = c(4.5, 6, 4, 7) + 0.1, mgp = c(3, 1, 0), cex.lab = 1.3, 
    font.lab = 2, cex.axis = 1.3, las = 1)
plot(c(0, log(BFMultiPi)), xlim = c(0, 100001), ylim = c(-20, 80), xlab = "", 
    ylab = "", cex.lab = 1.3, cex.axis = 1.3, las = 1, yaxt = "n", bty = "n", 
    type = "n", pch = 21, bg = "grey", axes = FALSE, lwd = 4, main = expression(paste("Multinomial", 
        ~logBF[0][1], ~"for", ~pi, sep = " ")), cex.main = 2)
axis(2, at = seq(-20, 80, 20), labels = seq(-20, 80, 20))
options(scipen = 100, digits = 4)
axis(1, at = seq(from = 0, to = 1e+05, by = 10000), labels = seq(from = 0, 
    to = 1e+05, by = 10000))
ablineclip(h = 0, lty = 2, x2 = 1e+05, y2 = 0)
mtext(expression(logBF[0][1]), side = 2, line = 3.1, las = 0, cex = 1.7)
mtext(expression("No. of Decimal Places of" ~ pi ~ "(No./1000)"), side = 1, 
    line = 3.1, las = 1, cex = 1.3)
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 170, maxColorValue = 255)
points(c(0, seq_along(N)), c(0, log(maxBFMultiPi)), type = "l", lwd = 4, 
    col = "red")
points(c(0, seq_along(N)), c(0, log(exBFMultiPi)), type = "l", lwd = 3, 
    col = greycol)
yy <- c(log(maxBFMultiPi), rev(log(exBFMultiPi)))
xx <- c(N/1000, rev(N/1000))
polygon(xx, yy, col = greycol)
text(10000, 7, "Evidence for H0", pos = 4, cex = 1.3)
text(10000, -7, "Evidence for H1", pos = 4, cex = 1.3)
arrows(7000, -2, 7000, -14, length = 0.25, angle = 30, code = 2, lwd = 2)
arrows(7000, 2, 7000, 14, length = 0.25, angle = 30, code = 2, lwd = 2)
points(c(0, seq_along(N)), c(0, log(BFMultiPi)), type = "l", lwd = 3, 
    col = "black")
op <- par(lend = 1)
legend(x = 54000, 45, legend = c(expression(max.BF[0][1]), expression(BF[0][1]), 
    expression("95%" ~ BF[0][1] ~ "|" ~ H[0])), lty = c(1, 1, 1), lwd = c(3, 
    3, 20), col = c("red", "black", greycol), bty = "n", x.intersp = 0.5, 
    cex = 1.2)
par(op)
text(39600, 76, "D(a=1)", cex = 1.3)
text(40000, 34.5, "D(a=50)", cex = 1.3)

# add Dirichlet a=50 prior

load("BFMultiPi50.rda")
load("maxBFMultiPi50.rda")
load("exBFMultiPi50.rda")

greycol2 <- rgb(red = 190, green = 190, blue = 190, alpha = 60, maxColorValue = 255)
yy <- c(log(maxBFMultiPi50), rev(log(exBFMultiPi50)))
xx <- c(N/1000, rev(N/1000))
polygon(xx, yy, col = greycol2)
red2 <- rgb(red = 255, green = 0, blue = 0, alpha = 80, maxColorValue = 255)
points(c(0, seq_along(N)), c(0, (log(maxBFMultiPi50))), type = "l", lwd = 4, 
    col = red2, lty = 1)
black2 <- red2 <- rgb(red = 100, green = 100, blue = 100, alpha = 200, 
    maxColorValue = 300)
points(c(0, seq_along(N)), c(0, (log(BFMultiPi50))), type = "l", lwd = 4, 
    lty = 1, col = black2)

10 Multiple Panels

To suitably impress the readership, any academic needs to be able to create a multi-panel graph. Below is a set of examples. When creating a multi-panel plot, the main challenge is to select the right number of panels (yes, you can have too many) so that the text and the symbols remain readible.

10.1 Two panel plot

This is one of my favorite plots, highlighting the difference between discrete probability mass and continous probability density. Credit goes to Michael Lee for conceptualizing the graph (it is presented in box 3.2 of our book) and to Quentin Gronau for the execution in R. Note the use of ablineclip for lines of distinct length and uniroot for finding the x-value that corresponds to five times the density of another x-value.

Show R-Code
library(plotrix)

# mix of 2 normal distributions
mixedNorm <- function(x) {
    return(0.5 * dnorm(x, 0.25, 0.13) + 0.5 * dnorm(x, 0.7, 0.082))
}
### normalize so that area [0,1] integrates to 1; k = normalizing constant
k <- 1/integrate(mixedNorm, 0, 1)$value

# normalized
pdfmix <- function(x, k) {
    return(k * (0.5 * dnorm(x, 0.25, 0.13) + 0.5 * dnorm(x, 0.7, 0.082)))
}

# integrate(pdfmix, 0.0790321,0.4048)$value # 0.4

op <- par(mfrow = c(1, 2), mar = c(5.9, 6, 4, 2) + 0.1)

barplot(height = c(0.2, 0.25, 0.1, 0.05, 0.35, 0.05), names.arg = c(1, 
    2, 3, 4, 5, 6), axes = FALSE, ylim = c(0, 1), width = 1, cex.names = 1.5)
arrows(x0 = 0.6, x1 = 0.6, y0 = 0.38, y1 = 0.23, length = c(0.2, 0.2), 
    lwd = 2)
text(0.6, 0.41, "0.2", cex = 1.3)
ablineclip(v = 1.9, y1 = 0.28, y2 = 0.375, lwd = 2)
ablineclip(v = 4.2, y1 = 0.28, y2 = 0.375, lwd = 2)
ablineclip(h = 0.375, x1 = 1.9, x2 = 4.2, lwd = 2)
arrows(x0 = 3.05, x1 = 3.05, y0 = 0.525, y1 = 0.375, length = c(0.2, 0.2), 
    lwd = 2)
text(3.05, 0.555, "0.4", cex = 1.3)
ablineclip(v = 5.5, y1 = 0.38, y2 = 0.43, lwd = 2)
arrows(x0 = 6.7, x1 = 6.7, y0 = 0.43, y1 = 0.09, length = c(0.2, 0.2), 
    lwd = 2)
ablineclip(h = 0.43, x1 = 5.5, x2 = 6.7, lwd = 2)
text(6.1, 0.46, "7 x", cex = 1.3)
par(las = 1)
axis(2, at = seq(0, 1, 0.1), labels = seq(0, 1, 0.1), lwd = 2, cex.axis = 1.3)
par(las = 0)
mtext("Probability Mass", side = 2, line = 3.7, cex = 2)
mtext("Value", side = 1, line = 3.7, cex = 2)

par(mar = c(4.6, 6, 3.3, 2) + 0.1)
xx <- c(0.0790321, 0.079031, seq(0.08, 0.4, 0.01), 0.4084, 0.4084)
yy <- c(0, pdfmix(0.079031, k = k), pdfmix(seq(0.08, 0.4, 0.01), k = k), pdfmix(0.4084, k = k), 
    0)
plot(1, type = "n", axes = FALSE, ylab = "", xlab = "", xlim = c(0, 1), 
    ylim = c(0, 3))
polygon(xx, yy, col = "grey", border = NA)
curve(pdfmix(x, k = k), from = 0, to = 1, lwd = 2, ylab = "", xlab = "", xlim = c(0, 
    1), ylim = c(0, 3), add = TRUE)
text(0.25, 0.7, "0.4", cex = 1.3)
par(las = 1)
axis(2, at = seq(0, 3, 0.5), labels = seq(0, 3, 0.5), lwd = 2, cex.axis = 1.3)
points(0.539580297, pdfmix(0.539580297, k = k), pch = 21, bg = "white", cex = 1.4, 
    lwd = 2.7)
points(uniroot(function(x) pdfmix(x, k = k) - 5 * pdfmix(0.539580297, k = k), interval = c(0.56, 
    0.7))$root, pdfmix(uniroot(function(x) pdfmix(x, k = k) - 5 * pdfmix(0.539580297, k = k), 
    interval = c(0.56, 0.7))$root, k = k), pch = 21, bg = "white", cex = 1.4, 
    lwd = 2.7)
arrows(x0 = 0.539580297, x1 = 0.539580297, y0 = 2.7, y1 = 0.7, length = c(0.17, 
    0.17), angle = 19, lwd = 2)
ablineclip(h = 2.7, x1 = 0.539580297, x2 = 0.6994507, lwd = 2)
ablineclip(v = 0.6994507, y1 = 2.55, y2 = 2.7, lwd = 2)
text(0.6194593, 2.79, "5 x", cex = 1.3)
axis(1, at = seq(0, 1, 0.1), labels = c("0", ".1", ".2", ".3", ".4", ".5", 
    ".6", ".7", ".8", ".9", "1"), line = -1.2, lwd = 2, cex.axis = 1.37)
par(las = 0)
mtext("Probability Density", side = 2, line = 3.7, cex = 2)
mtext("Value", side = 1, line = 2.4, cex = 2)

par(op)

10.2 Buffon’s Needle

The only way to understand the title (and the plot) is to visit the Wikipedia entry on Buffon’s needle. Anyway, this is another two-panel plot, showing two posterior distributions for estimating π using an experiment that involved tossing a needle (ad nauseam).

Show R-Code
library(plotrix)
source("HDIofMCMC.R")

load("mcmcChain1.rda")
load("mcmcChain2.rda")

op <- par(mfrow = c(1, 2))

par(cex.main = 1.5, mar = c(5.5, 5.5, 5.9, 3) + 0.1, mgp = c(3.5, 1, 0), 
    cex.lab = 1.5, font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
y <- hist(mcmcChain1[, "pihat"], freq = F, main = "", xlab = "", ylab = " ", 
    xlim = c(2.1, 5.1), axes = FALSE, breaks = 24, ylim = c(0, 2), yaxt = "n", 
    col = "grey")
axis(1, at = c(2.1, 2.6, pi, 3.6, 4.1, 4.6, 5.1), labels = c(2.1, 2.6, 
    expression(pi), 3.6, 4.1, 4.6, 5.1), lwd = 2, lwd.ticks = 2, line = -0.1)
ablineclip(h = 0, x1 = 5.1, col = "white")
axis(2, at = seq(0, 2, 0.5), line = -0.2, lwd = 2, lwd.ticks = 2)
mtext(expression(hat(pi)), side = 1, line = 4, cex = 2.4, font = 2, adj = 0.5)
mtext("Density", side = 2, line = 3.7, cex = 2.4, font = 2, las = 0)
lines(density(mcmcChain1[, "pihat"], from = 2.1, to = 5.1), lwd = 4)
HDI <- HDIofMCMC(mcmcChain1[, "pihat"])
arrows(x0 = HDI[1], y0 = 1.4, x1 = HDI[2], y1 = 1.4, angle = 90, length = 0.1, 
    code = 3, lwd = 2.2)
text("95% HDI", x = mean(HDI), y = 1.48, cex = 1.8)
text(expression(P(cross) ~ "= .5"), x = 3.99, y = 1, cex = 1.5)


par(cex.main = 1.5, mar = c(5.5, 5.5, 5.9, 3) + 0.1, mgp = c(3.5, 1, 0), 
    cex.lab = 1.5, font.lab = 2, cex.axis = 1.8, bty = "n", las = 1)
h <- hist(mcmcChain2[, "pihat"], freq = F, main = "", xlab = "", ylab = " ", 
    xlim = c(2.1, 5.1), axes = FALSE, col = "grey", breaks = 17, ylim = c(0, 
        2), , xaxt = "n")
axis(1, at = c(2.1, 2.6, pi, 3.6, 4.1, 4.6, 5.1), labels = c(2.1, 2.6, 
    expression(pi), 3.6, 4.1, 4.6, 5.1), lwd = 2, lwd.ticks = 2, line = -0.1)
axis(2, at = seq(0, 2, 0.5), lwd = 2, lwd.ticks = 2, line = -0.2)
mtext(expression(hat(pi)), side = 1, line = 4, cex = 2.4, font = 2, adj = 0.5)
mtext("Density", side = 2, line = 3.7, cex = 2.4, font = 2, las = 0)
lines(density(mcmcChain2[, "pihat"], from = 2.1, to = 5.1), lwd = 4)
HDI <- HDIofMCMC(mcmcChain2[, "pihat"])
arrows(x0 = HDI[1], y0 = 1.73, x1 = HDI[2], y1 = 1.73, angle = 90, length = 0.1, 
    code = 3, lwd = 2.2)
text("95% HDI", x = mean(HDI), y = 1.81, cex = 1.8)
text(expression(P(cross) ~ "= .63"), x = 4.12, y = 1, cex = 1.5)
mtext(expression("Posterior of" ~ hat(pi)), side = 3, line = -4.6, outer = TRUE, 
    cex = 3.3)

par(op)

10.3 Anscombe’s Quartet

Sometimes a graph is worth a thousand words. Anscombe’s quartet famously drives home the idea that you should always plot your data. This code is based on the Anscombe plot in R. We personally don’t like lapply and similar complications – it may do the trick but when you have to describe the code as “magic” this signals a communication problem. Anyway, the point of the example is graphical display of course. As always, note the thick lines, the large symbols, and the large font size.

Show R-Code
# rm(list = ls())

library(stats)
library(graphics)
library(plotrix)

# summary(anscombe) -- now some 'magic' to do the 4 regressions in a
# loop:
ff <- y ~ x
for (i in 1:4) {
    ff[2:3] <- lapply(paste(c("y", "x"), i, sep = ""), as.name)
    ## or ff[[2]] <- as.name(paste('y', i, sep='')) ff[[3]] <-
    ## as.name(paste('x', i, sep=''))
    assign(paste("lm.", i, sep = ""), lmi <- lm(ff, data = anscombe))
    # print(anova(lmi))
}

op <- par(mfrow = c(2, 2), mar = 0.1 + c(4, 4, 1, 1), oma = c(0, 0, 2, 
    0), cex.lab = 1.5, font.lab = 1.5, cex.axis = 1.3, bty = "n", las = 1, 
    cex.main = 1.5)

for (i in 1:4) {
    ff[2:3] <- lapply(paste(c("y", "x"), i, sep = ""), as.name)
    plot(ff, data = anscombe, col = "black", pch = 21, bg = "grey", cex = 2, 
        xlim = c(3, 21), ylim = c(3, 13), ylab = "", xlab = "", axes = F)
    axis(1, at = seq(3, 21, 3))
    axis(2)
    text(15, 6, "r = 0.816", cex = 1.5)
    # mtext(ff[2:3][[1]], side=2, line=2.5, cex=1.3) #y-labels
    # mtext(ff[2:3][[2]], side=1, line=2.5, cex=1.3) #x-labels
    ablineclip(get(paste("lm.", i, sep = "")), x1 = 3, x2 = 21, col = "black", 
        lwd = 2)
}

mtext("Anscombe's Quartet", outer = TRUE, cex = 1.5)
par(op)

10.4 Four Quite Different Panels

Each panel of this plot shows something very different: histogram, density, point plot, and function. We like the annotations too.

Show R-Code
################################## load data #############

# Social Priming Research, all between-subject studies, N=159:
dataSocialPriming <- read.csv("SocialPriming.csv", sep = ";")
# Control Studies, between-subject, N=130:
dataControlsSocialPriming <- read.csv("ControlsSocialPriming.csv", sep = ";")

# p values
pValuesSocialPriming <- dataSocialPriming$pvalue
pValuesControlsSocialPriming <- dataControlsSocialPriming$pvalue

################################## 4-panel plot ###########

source("HDIofMCMC.R")

plotphi <- function(samples, Nbreaks = 80, xlow = 0, xhigh = 1, ylow = 0, 
    yhigh = 10) {
	
    # Plots the mixture proportion p(H0)

    phi <- samples$BUGSoutput$sims.list$phi
    par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), 
        cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
    y <- hist(phi, Nbreaks, plot = F)
    plot(c(y$breaks, max(y$breaks)), c(0, y$density, 0), type = "S", lwd = 2, 
        lty = 1, xlim = c(xlow, xhigh), ylim = c(ylow, yhigh), xlab = "", 
        ylab = "", col = "black")
    mtext("H0 Assignment Rate", side = 1, line = 2.7, cex = 1.5)
    par(las = 0)
    mtext("Posterior Density", side = 2, line = 2.5, cex = 1.5)
    lines(c(0.5, 0.5), c(ylow, yhigh), cex = 2, lty = 2)
}

plotz <- function(pvals, samples) {
	
    # Plots the p-value against the probability of being classified as from H0
	
    z <- samples$BUGSoutput$mean$ind
    par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), 
        cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
    plot(sort(pvals, dec = TRUE), z, col = "black", pch = 21, bg = "grey", 
        cex = 2, xlim = c(0, 0.05), ylim = c(0, 1), ylab = "", xlab = "", 
        axes = F)
    axis(1)
    axis(2)
    par(las = 0)
    mtext("Significant P Values", side = 1, line = 2.9, cex = 1.5)
    mtext("Probability H0 Assignment", side = 2, line = 3.5, cex = 1.5)
    lines(c(0, 0.05), c(0.5, 0.5), cex = 2, lty = 2)
}

plotpredqq <- function(pvals, samples, ks.test = FALSE) {
	
    # Draws qq plot; computes ks test
	
    predp <- pnorm(samples$BUGSoutput$sims.list$predqp)
    par(cex.main = 1.5, mar = c(5, 6, 4, 4) + 0.1, mgp = c(3.5, 1, 0), 
        cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
    qqplot(pvals, predp, xlab = "", ylab = "", axes = F, col = "black")
    axis(1)
    axis(2)
    mtext("Observed P Value Quantiles", side = 1, line = 2.9, cex = 1.5)
    par(las = 0)
    mtext("Predicted Quantiles ", side = 2, line = 3.7, cex = 1.7)
    abline(a = 0, b = 1, lty = 3)
    if (ks.test == TRUE) 
        ks.test(pvals, predp)
}

histP <- function(pvals, samples, yhigh = 100, col = "lightblue") {
	
    # Plots histogram of the p-values
	
    predp <- pnorm(samples$BUGSoutput$sims.list$predqp)
    par(cex.main = 1.5, mar = c(5, 6, 4, 4) + 0.1, mgp = c(3.5, 1, 0), 
        cex.lab = 1.5, font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
    hist(pvals, freq = TRUE, xlab = "", ylab = "", col = col, main = "", 
        ylim = c(0, yhigh), xlim = c(0, 0.05), axes = F)
    axis(1)
    par(las = 1)
    axis(2)
    mtext("Significant P Values", side = 1, line = 2.9, cex = 1.5)
    par(las = 0)
    mtext("Number of P Values", side = 2, line = 3.3, cex = 1.6)
    rug(pvals)
}

### load samples

load("samplesSocialPriming_DirichletJags.Rdata")
load("samplesControlsSocialPriming_DirichletJags.Rdata")

pvals <- pValuesSocialPriming
pvals2 <- pValuesControlsSocialPriming
samplesP <- samplesSocialPriming_DirichletJags
samplesP2 <- samplesControlsSocialPriming_DirichletJags

### create plot

op <- par(mfrow = c(2, 2))

yhigh <- 80
greycol2 <- rgb(0, 0, 0, alpha = 0.7)
histP(pvals, samplesP, yhigh, col = greycol2)
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 95, maxColorValue = 255)
hist(pvals2, freq = TRUE, xlab = "", ylab = "", main = "", ylim = c(0, 
    yhigh), xlim = c(0, 0.05), col = greycol, axes = F, add = TRUE, lty = 2)
op2 <- par(lend = 1)
legend(x = 0.006, 45, legend = c("Social Priming Studies (N=159)", "Control Studies (N=130)"), 
    lty = c(1, 1, 1), lwd = c(15, 15), col = c(greycol2, greycol), bty = "n", 
    x.intersp = 0.5, cex = 1.4)
par(op2)

plotphi(samplesP, yhigh = 6)
Nbreaks <- 80
xlow <- 0
xhigh <- 1
ylow <- 0
yhigh <- 10
phi1 <- samplesP$BUGSoutput$sims.list$phi
phi2 <- samplesP2$BUGSoutput$sims.list$phi
y <- hist(phi2, Nbreaks, plot = F)
greycol2 <- rgb(0, 0, 0, alpha = 0.5)
lines(c(y$breaks, max(y$breaks)), c(0, y$density, 0), lwd = 2, lty = 1, 
    col = greycol2)
par(las = 1)
text(0.91, 2.7, c("Social \nPriming \nStudies"), cex = 1.3)
text(0.09, 3.5, c("Control \nStudies"), cex = 1.3)
HDI1 <- HDIofMCMC(phi1)  # [0.414, 0.865]
HDI2 <- HDIofMCMC(phi2)  # [0.061, 0.446]
arrows(x0 = HDI1[1], y0 = 4, x1 = HDI1[2], y1 = 4, angle = 90, code = 3, 
    length = 0.08)
mtext("95%", side = 3, at = mean(HDI1), line = -5)
arrows(x0 = HDI2[1], y0 = 4.8, x1 = HDI2[2], y1 = 4.8, angle = 90, code = 3, 
    length = 0.08, col = greycol2)
mtext("95%", side = 3, at = mean(HDI2), line = -3.1, col = greycol2)

plotz(pvals, samplesP)
z <- samplesP2$BUGSoutput$mean$ind
greycol <- rgb(red = 190, green = 190, blue = 190, alpha = 40, maxColorValue = 255)
greycol2 <- rgb(0, 0, 0, alpha = 0.12)
points(sort(pvals2, dec = TRUE), z, col = greycol2, pch = 21, bg = greycol, 
    cex = 2)
text(0.02, 0.92, "Social Priming Studies", cex = 1.4, pos = 4)
text(0.025, 0.38, "Control Studies", cex = 1.4, pos = 4)

plotpredqq(pvals, samplesP)
predp <- pnorm(samplesP2$BUGSoutput$sims.list$predqp)
d <- qqplot(pvals2, predp, xlab = "", ylab = "", axes = FALSE, plot = FALSE)
greycol2 <- rgb(0, 0, 0, alpha = 0.3)
points(d$x, d$y, col = greycol2)
legend(0.019, 0.019, legend = c("Social Priming Studies", "Control Studies"), 
    pch = rep(1, 2), col = c("black", greycol2), lwd = c(2.3, 2.3), lty = c(NA, 
        NA), bty = "n", x.intersp = 0, cex = 1.4)

par(op)

10.5 Nine-Panel Posterior Predictives

Ravi Selker enters the stage to present a nine-panel plot of posterior predictives. Note the use of textGrob and arrangeGrob. Nice work.

Show R-Code
library(ggmcmc)
library(gridExtra)
library(grid)

Mode <- function(x) {
    ux <- unique(x)
    ux[which.max(tabulate(match(x, ux)))]
}

load("PostPredCheck.Rdata")

############################################## GRAPHS ###

postpred <- list()
for (i in 1:3) postpred[[i]] <- list()

for (i in 1:3) {
    for (j in 1:3) {
        postpred[[i]][[j]] <- ggplot(data[[i]][[j]], aes(x = ypred, y = yobs, 
            size = factor(nrow))) + geom_point() + coord_flip() + theme(panel.grid.minor = element_blank(), 
            plot.title = element_blank(), panel.grid.major = element_blank(), 
            legend.position = "none", axis.title.x = element_blank(), 
            axis.title.y = element_blank(), axis.text.x = element_text(size = 14), 
            axis.text.y = element_text(size = 14), panel.background = element_rect(fill = "white", 
                colour = "white"), panel.border = element_blank(), axis.line = element_line(size = 1.1), 
            plot.margin = unit(c(0.1, 0.1, 0.1, 0.1), "cm")) + geom_abline(size = 1.1)
    }
}

############################################## PLOT ALL GRAPHS IN ONE FIGURE ###

T1 <- textGrob("1 Truth", gp = gpar(cex = 1.5))
T2 <- textGrob("2 Truths", gp = gpar(cex = 1.5))
T3 <- textGrob("3 Truths", gp = gpar(cex = 1.5))

xlab <- textGrob("Predicted Ranking", gp = gpar(cex = 2))
ylab <- textGrob("Observed Ranking", gp = gpar(cex = 2), rot = 90)

Tlab <- textGrob("Data Generated Using", gp = gpar(cex = 2), rot = 270)
Mlab <- textGrob("Model Assumption", gp = gpar(cex = 2))
blank <- textGrob("", gp = gpar(cex = 1.5))

grid.arrange(arrangeGrob(blank, blank, ylab, blank, nrow = 4, heights = c(0.2, 
    0.2, 3, 0.3)), arrangeGrob(arrangeGrob(blank, Mlab, blank, ncol = 3, 
    widths = c(0.3, 3, 0.1)), arrangeGrob(blank, T1, blank, T2, blank, 
    T3, ncol = 6, widths = c(0.15, 1, 0.15, 1, 0.15, 1)), arrangeGrob(postpred[[1]][[1]], 
    postpred[[1]][[2]], postpred[[1]][[3]], ncol = 3), arrangeGrob(postpred[[2]][[1]], 
    postpred[[2]][[2]], postpred[[2]][[3]], ncol = 3), arrangeGrob(postpred[[3]][[1]], 
    postpred[[3]][[2]], postpred[[3]][[3]], ncol = 3), arrangeGrob(blank, 
    xlab, blank, ncol = 3, widths = c(0.3, 3, 0.1)), nrow = 6, heights = c(0.2, 
    0.2, 1, 1, 1, 0.2)), arrangeGrob(blank, blank, T1, T2, T3, blank, 
    nrow = 6, heights = c(0.2, 0.2, 1, 1, 1, 0.3)), arrangeGrob(blank, 
    blank, Tlab, blank, nrow = 4, heights = c(0.2, 0.2, 3, 0.3)), ncol = 4, 
    widths = c(0.2, 2.8, 0.4, 0.2))

11 Graphs from JASP

Our lab at the University of Amsterdam has developed JASP, a free and open-source program for statistical analysis. In many ways, JASP is SPSS done right: minimalist output with progressive disclosure, dynamic updating of results, Bayesian analysis options, and, of course, clean graphs. Below is a series of JASP graphs.

11.1 Correlation Matrix

This multi-panel plot combines several elements that should now be familiar: correlation plots, histograms with density estimators, and, on the lower diagonal, the associated statistics.

Show R-Code
.plotMarginalCor <- function(variable, cexYlab = 1.3, lwd = 2, rugs = FALSE) {
    
    # histogram with density estimator
    
    variable <- variable[!is.na(variable)]
    
    density <- density(variable)
    h <- hist(variable, plot = FALSE)
    jitVar <- jitter(variable)
    yhigh <- max(max(h$density), max(density$y))
    ylow <- 0
    xticks <- pretty(c(variable, h$breaks), min.n = 3)
    plot(range(xticks), c(ylow, yhigh), type = "n", axes = FALSE, ylab = "", 
        xlab = "")
    h <- hist(variable, freq = FALSE, main = "", ylim = c(ylow, yhigh), xlab = "", 
        ylab = " ", axes = FALSE, col = "grey", add = TRUE, nbreaks = round(length(variable)/5))
    ax1 <- axis(1, line = 0.3, at = xticks, lab = xticks)
    par(las = 0)
    ax2 <- axis(2, at = c(0, max(max(h$density), max(density$y))/2, max(max(h$density), 
        max(density$y))), labels = c("", "Density", ""), lwd.ticks = 0, 
        pos = range(ax1) - 0.08 * diff(range(ax1)), cex.axis = 1.7, mgp = c(3, 
            0.7, 0))
    
    if (rugs) 
        rug(jitVar)
    
    lines(density$x[density$x >= min(ax1) & density$x <= max(ax1)], density$y[density$x >= 
        min(ax1) & density$x <= max(ax1)], lwd = lwd)
}

.poly.pred <- function(fit, line = FALSE, xMin, xMax, lwd) {
    
    # predictions of fitted model
    
    # create function formula
    f <- vector("character", 0)
    
    for (i in seq_along(coef(fit))) {
        
        if (i == 1) {
            
            temp <- paste(coef(fit)[[i]])
            f <- paste(f, temp, sep = "")
        }
        
        if (i > 1) {
            
            temp <- paste("(", coef(fit)[[i]], ")*", "x^", i - 1, sep = "")
            f <- paste(f, temp, sep = "+")
        }
    }
    
    x <- seq(xMin, xMax, length.out = 100)
    predY <- eval(parse(text = f))
    
    if (line == FALSE) {
        return(predY)
    }
    
    if (line) {
        lines(x, predY, lwd = lwd)
    }
}


.plotScatter <- function(xVar, yVar, cexPoints = 1.3, cexXAxis = 1.3, 
    cexYAxis = 1.3, lwd = 2) {
    
    # displays scatterplot
    
    d <- data.frame(xx = xVar, yy = yVar)
    d <- na.omit(d)
    xVar <- d$xx
    yVar <- d$yy
    
    fit <- lm(yy ~ poly(xx, 1, raw = TRUE), d)
    
    xlow <- min((min(xVar) - 0.1 * min(xVar)), min(pretty(xVar)))
    xhigh <- max((max(xVar) + 0.1 * max(xVar)), max(pretty(xVar)))
    xticks <- pretty(c(xlow, xhigh))
    ylow <- min((min(yVar) - 0.1 * min(yVar)), min(pretty(yVar)), min(.poly.pred(fit, 
        line = FALSE, xMin = xticks[1], xMax = xticks[length(xticks)], 
        lwd = lwd)))
    yhigh <- max((max(yVar) + 0.1 * max(yVar)), max(pretty(yVar)), max(.poly.pred(fit, 
        line = FALSE, xMin = xticks[1], xMax = xticks[length(xticks)], 
        lwd = lwd)))
    
    
    yticks <- pretty(c(ylow, yhigh))
    
    yLabs <- vector("character", length(yticks))
    
    for (i in seq_along(yticks)) {
        
        if (yticks[i] < 10^6) {
            
            yLabs[i] <- format(yticks[i], digits = 3, scientific = FALSE)
            
        } else {
            
            yLabs[i] <- format(yticks[i], digits = 3, scientific = TRUE)
        }
    }
    
    plot(xVar, yVar, col = "black", pch = 21, bg = "grey", ylab = "", 
        xlab = "", axes = FALSE, ylim = range(yticks), xlim = range(xticks), 
        cex = cexPoints)
    .poly.pred(fit, line = TRUE, xMin = xticks[1], xMax = xticks[length(xticks)], 
        lwd = lwd)
    
    par(las = 1)
    
    axis(1, line = 0.4, labels = xticks, at = xticks, cex.axis = cexXAxis)
    axis(2, line = 0.2, labels = yLabs, at = yticks, cex.axis = cexYAxis)
    
    invisible(max(nchar(yLabs)))
}

.plotCorValue <- function(xVar, yVar, cexText = 2.5, cexCI = 1.7, hypothesis = "correlated", 
    pearson = TRUE, kendallsTauB = FALSE, spearman = FALSE, confidenceInterval = 0.95) {
    
    # displays correlation value
    
    CIPossible <- TRUE
    
    tests <- c()
    
    if (pearson) 
        tests <- c(tests, "pearson")
    
    if (spearman) 
        tests <- c(tests, "spearman")
    
    if (kendallsTauB) 
        tests <- c(tests, "kendall")
    
    plot(1, 1, type = "n", axes = FALSE, ylab = "", xlab = "")
    
    lab <- vector("list")
    
    for (i in seq_along(tests)) {
        
        if (round(cor.test(xVar, yVar, method = tests[i])$estimate, 8) == 
            1) {
            
            CIPossible <- FALSE
            
            if (tests[i] == "pearson") {
                lab[[i]] <- bquote(italic(r) == "1.000")
            }
            
            if (tests[i] == "spearman") {
                lab[[i]] <- bquote(italic(rho) == "1.000")
            }
            
            if (tests[i] == "kendall") {
                lab[[i]] <- bquote(italic(tau) == "1.000")
            }
            
        } else if (round(cor.test(xVar, yVar, method = tests[i])$estimate, 
            8) == -1) {
            
            CIPossible <- FALSE
            
            if (tests[i] == "pearson") {
                lab[[i]] <- bquote(italic(r) == "-1.000")
            }
            
            if (tests[i] == "spearman") {
                lab[[i]] <- bquote(italic(rho) == "-1.000")
            }
            
            if (tests[i] == "kendall") {
                lab[[i]] <- bquote(italic(tau) == "-1.000")
            }
            
        } else {
            
            if (tests[i] == "pearson") {
                lab[[i]] <- bquote(italic(r) == .(formatC(round(cor.test(xVar, 
                  yVar, method = tests[i])$estimate, 3), format = "f", 
                  digits = 3)))
            }
            
            if (tests[i] == "spearman") {
                lab[[i]] <- bquote(rho == .(formatC(round(cor.test(xVar, 
                  yVar, method = tests[i])$estimate, 3), format = "f", 
                  digits = 3)))
            }
            
            if (tests[i] == "kendall") {
                lab[[i]] <- bquote(tau == .(formatC(round(cor.test(xVar, 
                  yVar, method = tests[i])$estimate, 3), format = "f", 
                  digits = 3)))
            }
        }
    }
    
    if (length(tests) == 1) {
        ypos <- 1
    }
    
    if (length(tests) == 2) {
        ypos <- c(1.1, 0.9)
    }
    
    if (length(tests) == 3) {
        ypos <- c(1.2, 1, 0.8)
    }
    
    
    for (i in seq_along(tests)) {
        
        text(1, ypos[i], labels = lab[[i]], cex = cexText)
    }
    
    
    if (hypothesis == "correlated" & length(tests) == 1 & any(tests == 
        "pearson")) {
        
        alternative <- "two.sided"
        ctest <- cor.test(xVar, yVar, method = tests, conf.level = confidenceInterval)
    }
    
    if (hypothesis != "correlated" & length(tests) == 1 & any(tests == 
        "pearson")) {
        
        if (hypothesis == "correlatedPositively") {
            
            ctest <- cor.test(xVar, yVar, method = tests, alternative = "greater", 
                conf.level = confidenceInterval)
            
        } else if (hypothesis == "correlatedNegatively") {
            
            ctest <- cor.test(xVar, yVar, method = tests, alternative = "less", 
                conf.level = confidenceInterval)
        }
        
    }
    
    if (any(tests == "pearson") & length(tests) == 1 && CIPossible) {
        
        CIlow <- formatC(round(ctest$conf.int[1], 3), format = "f", digits = 3)
        CIhigh <- formatC(round(ctest$conf.int[2], 3), format = "f", digits = 3)
        
        text(1, 0.8, labels = paste(100 * confidenceInterval, "% CI: [", 
            CIlow, ", ", CIhigh, "]", sep = ""), cex = cexCI)
    }
    
}

### matrix plot ###

dataset <- read.csv("obk.long_correct.csv")
variables <- c("pre.2", "pre.3", "pre.5", "post.3", "post.5")

l <- length(variables)

par(mfrow = c(l, l), cex.axis = 1.3, mar = c(3, 4, 2, 1.5) + 0.1, oma = c(0, 
    2.2, 2, 0))

for (row in seq_len(l)) {
    
    for (col in seq_len(l)) {
        
        if (row == col) {
            .plotMarginalCor(dataset[[variables[row]]])  # plot marginal (histogram with density estimator)
        }
        if (col > row) {
            .plotScatter(dataset[[variables[col]]], dataset[[variables[row]]])  # plot scatterplot
        }
        if (col < row) {
            if (l < 7) {
                .plotCorValue(dataset[[variables[col]]], dataset[[variables[row]]], 
                  cexCI = 1.2)  # plot r= ...
            }
            if (l >= 7) {
                .plotCorValue(dataset[[variables[col]]], dataset[[variables[row]]], 
                  cexCI = 1.2)
            }
        }
    }
}

textpos <- seq(1/(l * 2), (l * 2 - 1)/(l * 2), 2/(l * 2))
for (t in seq_along(textpos)) {
    mtext(text = variables[t], side = 3, outer = TRUE, at = textpos[t], 
        cex = 1.9, line = -0.8)
    mtext(text = variables[t], side = 2, outer = TRUE, at = rev(textpos)[t], 
        cex = 1.9, line = -0.1)
}

11.2 Prior and Posterior

This is one of our favorite JASP graphs. Note the balance between the graphical elements. When it comes to inference about the equality of two means (which is the JASP analysis that yields this plot), this graph provides: (1) the prior distribution of effect size; (2) the posterior distribution of effect size; (3) the 95% credible interval; (4) the posterior median;(5) the Bayes factor; (6) a Savage-Dickey visualization of the Bayes factor by means of the height ratio for the grey dots shown at an effect size of zero; (7) a pizza plot visualization of the Bayes factor. That’s a lot of information, but the graph is still relatively clean.

Show R-Code
library(plotrix)

.likelihoodShiftedT <- function(par, data) {
    
    -sum(log(dt((data - par[1])/par[2], par[3])/par[2]))
    
}

.dposteriorShiftedT <- function(x, parameters, oneSided) {
    
    # function that returns the posterior density
    
    if (oneSided == FALSE) {
        
        dt((x - parameters[1])/parameters[2], parameters[3])/parameters[2]
        
    } else if (oneSided == "right") {
        
        ifelse(x >= 0, (dt((x - parameters[1])/parameters[2], parameters[3])/parameters[2])/pt((0 - 
            parameters[1])/parameters[2], parameters[3], lower.tail = FALSE), 
            0)
        
    } else if (oneSided == "left") {
        
        ifelse(x <= 0, (dt((x - parameters[1])/parameters[2], parameters[3])/parameters[2])/pt((0 - 
            parameters[1])/parameters[2], parameters[3], lower.tail = TRUE), 
            0)
        
    }
    
}

.dprior <- function(x, r, oneSided = oneSided) {
    
    # function that returns the prior density
    
    if (oneSided == "right") {
        
        y <- ifelse(x < 0, 0, 2/(pi * r * (1 + (x/r)^2)))
        return(y)
    }
    
    if (oneSided == "left") {
        
        y <- ifelse(x > 0, 0, 2/(pi * r * (1 + (x/r)^2)))
        return(y)
    } else {
        
        return(1/(pi * r * (1 + (x/r)^2)))
    }
}

.plotPosterior.ttest <- function(x = NULL, y = NULL, paired = FALSE, oneSided = FALSE, 
    BF, BFH1H0 = TRUE, iterations = 10000, rscale = "medium", lwd = 2, 
    cexPoints = 1.5, cexAxis = 1.2, cexYlab = 1.5, cexXlab = 1.5, cexTextBF = 1.4, 
    cexCI = 1.1, cexLegend = 1.2, lwdAxis = 1.2, addInformation = TRUE, 
    dontPlotData = FALSE) {
    
    if (addInformation) {
        
        par(mar = c(5.6, 5, 7, 4) + 0.1, las = 1)
        
    } else {
        
        par(mar = c(5.6, 5, 4, 4) + 0.1, las = 1)
    }
    
    if (dontPlotData) {
        
        plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE, 
            xlab = "", ylab = "")
        
        axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            xlab = "")
        axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            ylab = "")
        
        mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 3.25)
        mtext(expression(paste("Effect size", ~delta)), side = 1, cex = cexXlab, 
            line = 2.5)
        
        return()
    }
    
    if (rscale == "medium") {
        r <- sqrt(2)/2
    }
    if (rscale == "wide") {
        r <- 1
    }
    if (rscale == "ultrawide") {
        r <- sqrt(2)
    }
    if (mode(rscale) == "numeric") {
        r <- rscale
    }
    
    if (oneSided == FALSE) {
        nullInterval <- NULL
    }
    if (oneSided == "right") {
        nullInterval <- c(0, Inf)
    }
    if (oneSided == "left") {
        nullInterval <- c(-Inf, 0)
    }
    
    # sample from delta posterior
    samples <- BayesFactor::ttestBF(x = x, y = y, paired = paired, posterior = TRUE, 
        iterations = iterations, rscale = r)
    
    delta <- samples[, "delta"]
    
    # fit shifted t distribution
    if (is.null(y)) {
        
        deltaHat <- mean(x)/sd(x)
        N <- length(x)
        df <- N - 1
        sigmaStart <- 1/N
        
    } else if (paired) {
        
        deltaHat <- mean(x - y)/sd(x - y)
        N <- length(x)
        df <- N - 1
        sigmaStart <- 1/N
        
    } else if (!is.null(y) && !paired) {
        
        N1 <- length(x)
        N2 <- length(y)
        sdPooled <- sqrt(((N1 - 1) * var(x) + (N2 - 1) * var(y))/(N1 + 
            N2))
        deltaHat <- (mean(x) - mean(y))/sdPooled
        df <- N1 + N2 - 2
        sigmaStart <- sqrt(N1 * N2/(N1 + N2))
    }
    
    if (sigmaStart < 0.01) 
        sigmaStart <- 0.01
    
    parameters <- try(silent = TRUE, expr = optim(par = c(deltaHat, sigmaStart, 
        df), fn = .likelihoodShiftedT, data = delta, method = "BFGS")$par)
    
    if (class(parameters) == "try-error") {
        
        parameters <- try(silent = TRUE, expr = optim(par = c(deltaHat, 
            sigmaStart, df), fn = .likelihoodShiftedT, data = delta, method = "Nelder-Mead")$par)
    }
    
    if (BFH1H0) {
        
        BF10 <- BF
        BF01 <- 1/BF10
        
    } else {
        
        BF01 <- BF
        BF10 <- 1/BF01
    }
    
    
    # set limits plot
    xlim <- vector("numeric", 2)
    
    if (oneSided == FALSE) {
        
        xlim[1] <- min(-2, quantile(delta, probs = 0.01)[[1]])
        xlim[2] <- max(2, quantile(delta, probs = 0.99)[[1]])
        
        if (length(x) < 10) {
            
            if (addInformation) {
                
                stretch <- 1.52
            } else {
                
                stretch <- 1.4
            }
            
        } else {
            
            stretch <- 1.2
        }
        
    }
    
    if (oneSided == "right") {
        
        # if (length(delta[delta >= 0]) < 10) return('Plotting is not
        # possible: To few posterior samples in tested interval')
        
        xlim[1] <- min(-2, quantile(delta[delta >= 0], probs = 0.01)[[1]])
        xlim[2] <- max(2, quantile(delta[delta >= 0], probs = 0.99)[[1]])
        
        if (any(is.na(xlim))) {
            
            xlim[1] <- min(-2, .qShiftedT(0.01, parameters, oneSided = "right"))
            xlim[2] <- max(2, .qShiftedT(0.99, parameters, oneSided = "right"))
            
        }
        
        stretch <- 1.32
    }
    
    if (oneSided == "left") {
        
        # if (length(delta[delta <= 0]) < 10) return('Plotting is not
        # possible: To few posterior samples in tested interval')
        
        xlim[1] <- min(-2, quantile(delta[delta <= 0], probs = 0.01)[[1]])
        xlim[2] <- max(2, quantile(delta[delta <= 0], probs = 0.99)[[1]])
        
        if (any(is.na(xlim))) {
            
            xlim[1] <- min(-2, .qShiftedT(0.01, parameters, oneSided = "left"))
            xlim[2] <- max(2, .qShiftedT(0.99, parameters, oneSided = "left"))
            
        }
        
        stretch <- 1.32
    }
    
    xticks <- pretty(xlim)
    
    ylim <- vector("numeric", 2)
    
    ylim[1] <- 0
    dmax <- optimize(function(x) .dposteriorShiftedT(x, parameters = parameters, 
        oneSided = oneSided), interval = range(xticks), maximum = TRUE)$objective
    ylim[2] <- max(stretch * .dprior(0, r, oneSided = oneSided), stretch * 
        dmax)  # get maximum density
    
    # calculate position of 'nice' tick marks and create labels
    yticks <- pretty(ylim)
    xlabels <- formatC(xticks, 1, format = "f")
    ylabels <- formatC(yticks, 1, format = "f")
    
    # compute 95% credible interval & median:
    if (oneSided == FALSE) {
        
        CIlow <- quantile(delta, probs = 0.025)[[1]]
        CIhigh <- quantile(delta, probs = 0.975)[[1]]
        medianPosterior <- median(delta)
        
        if (any(is.na(c(CIlow, CIhigh, medianPosterior)))) {
            
            CIlow <- .qShiftedT(0.025, parameters, oneSided = FALSE)
            CIhigh <- .qShiftedT(0.975, parameters, oneSided = FALSE)
            medianPosterior <- .qShiftedT(0.5, parameters, oneSided = FALSE)
        }
    }
    
    if (oneSided == "right") {
        
        CIlow <- quantile(delta[delta >= 0], probs = 0.025)[[1]]
        CIhigh <- quantile(delta[delta >= 0], probs = 0.975)[[1]]
        medianPosterior <- median(delta[delta >= 0])
        
        if (any(is.na(c(CIlow, CIhigh, medianPosterior)))) {
            
            CIlow <- .qShiftedT(0.025, parameters, oneSided = "right")
            CIhigh <- .qShiftedT(0.975, parameters, oneSided = "right")
            medianPosterior <- .qShiftedT(0.5, parameters, oneSided = "right")
        }
    }
    
    if (oneSided == "left") {
        
        CIlow <- quantile(delta[delta <= 0], probs = 0.025)[[1]]
        CIhigh <- quantile(delta[delta <= 0], probs = 0.975)[[1]]
        medianPosterior <- median(delta[delta <= 0])
        
        if (any(is.na(c(CIlow, CIhigh, medianPosterior)))) {
            
            CIlow <- .qShiftedT(0.025, parameters, oneSided = "left")
            CIhigh <- .qShiftedT(0.975, parameters, oneSided = "left")
            medianPosterior <- .qShiftedT(0.5, parameters, oneSided = "left")
        }
        
    }
    
    posteriorLine <- .dposteriorShiftedT(x = seq(min(xticks), max(xticks), 
        length.out = 1000), parameters = parameters, oneSided = oneSided)
    
    xlim <- c(min(CIlow, range(xticks)[1]), max(range(xticks)[2], CIhigh))
    
    plot(1, 1, xlim = xlim, ylim = range(yticks), ylab = "", xlab = "", 
        type = "n", axes = FALSE)
    
    lines(seq(min(xticks), max(xticks), length.out = 1000), posteriorLine, 
        lwd = lwd)
    lines(seq(min(xticks), max(xticks), length.out = 1000), .dprior(seq(min(xticks), 
        max(xticks), length.out = 1000), r = r, oneSided = oneSided), 
        lwd = lwd, lty = 3)
    
    axis(1, at = xticks, labels = xlabels, cex.axis = cexAxis, lwd = lwdAxis)
    axis(2, at = yticks, labels = ylabels, , cex.axis = cexAxis, lwd = lwdAxis)
    
    
    if (nchar(ylabels[length(ylabels)]) > 4) {
        
        mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 4)
        
    } else if (nchar(ylabels[length(ylabels)]) == 4) {
        
        mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 3.25)
        
    } else if (nchar(ylabels[length(ylabels)]) < 4) {
        
        mtext(text = "Density", side = 2, las = 0, cex = cexYlab, line = 2.85)
        
    }
    
    mtext(expression(paste("Effect size", ~delta)), side = 1, cex = cexXlab, 
        line = 2.5)
    
    points(0, .dprior(0, r, oneSided = oneSided), col = "black", pch = 21, 
        bg = "grey", cex = cexPoints)
    
    if (oneSided == FALSE) {
        
        heightPosteriorAtZero <- .dposteriorShiftedT(0, parameters = parameters, 
            oneSided = oneSided)
        
    } else if (oneSided == "right") {
        
        posteriorLineLargerZero <- posteriorLine[posteriorLine > 0]
        heightPosteriorAtZero <- posteriorLineLargerZero[1]
        
    } else if (oneSided == "left") {
        
        posteriorLineLargerZero <- posteriorLine[posteriorLine > 0]
        heightPosteriorAtZero <- posteriorLineLargerZero[length(posteriorLineLargerZero)]
    }
    
    points(0, heightPosteriorAtZero, col = "black", pch = 21, bg = "grey", 
        cex = cexPoints)
    
    ### 95% credible interval
    
    # enable plotting in margin
    par(xpd = TRUE)
    
    yCI <- grconvertY(dmax, "user", "ndc") + 0.04
    yCI <- grconvertY(yCI, "ndc", "user")
    
    arrows(CIlow, yCI, CIhigh, yCI, angle = 90, code = 3, length = 0.1, 
        lwd = lwd)
    
    medianText <- formatC(medianPosterior, digits = 3, format = "f")
    
    if (addInformation) {
        
        # display BF10 value
        offsetTopPart <- 0.06
        
        yy <- grconvertY(0.75 + offsetTopPart, "ndc", "user")
        yy2 <- grconvertY(0.806 + offsetTopPart, "ndc", "user")
        
        xx <- min(xticks)
        
        if (BF10 >= 1000000 | BF01 >= 1000000) {
            
            BF10t <- formatC(BF10, 3, format = "e")
            BF01t <- formatC(BF01, 3, format = "e")
        }
        
        if (BF10 < 1000000 & BF01 < 1000000) {
            
            BF10t <- formatC(BF10, 3, format = "f")
            BF01t <- formatC(BF01, 3, format = "f")
        }
        
        if (oneSided == FALSE) {
            
            text(xx, yy2, bquote(BF[10] == .(BF10t)), cex = cexTextBF, 
                pos = 4)
            text(xx, yy, bquote(BF[0][1] == .(BF01t)), cex = cexTextBF, 
                pos = 4)
        }
        
        if (oneSided == "right") {
            
            text(xx, yy2, bquote(BF["+"][0] == .(BF10t)), cex = cexTextBF, 
                pos = 4)
            text(xx, yy, bquote(BF[0]["+"] == .(BF01t)), cex = cexTextBF, 
                pos = 4)
        }
        
        if (oneSided == "left") {
            
            text(xx, yy2, bquote(BF["-"][0] == .(BF10t)), cex = cexTextBF, 
                pos = 4)
            text(xx, yy, bquote(BF[0]["-"] == .(BF01t)), cex = cexTextBF, 
                pos = 4)
        }
        
        yy <- grconvertY(0.756 + offsetTopPart, "ndc", "user")
        yy2 <- grconvertY(0.812 + offsetTopPart, "ndc", "user")
        
        CIText <- paste("95% CI: [", bquote(.(formatC(CIlow, 3, format = "f"))), 
            ", ", bquote(.(formatC(CIhigh, 3, format = "f"))), "]", sep = "")
        medianLegendText <- paste("median =", medianText)
        
        text(max(xticks), yy2, medianLegendText, cex = 1.1, pos = 2)
        text(max(xticks), yy, CIText, cex = 1.1, pos = 2)
        
        # probability wheel
        if (max(nchar(BF10t), nchar(BF01t)) <= 4) {
            xx <- grconvertX(0.44, "ndc", "user")
        }
        
        if (max(nchar(BF10t), nchar(BF01t)) == 5) {
            xx <- grconvertX(0.44 + 0.001 * 5, "ndc", "user")
        }
        
        if (max(nchar(BF10t), nchar(BF01t)) == 6) {
            xx <- grconvertX(0.44 + 0.001 * 6, "ndc", "user")
        }
        
        if (max(nchar(BF10t), nchar(BF01t)) == 7) {
            xx <- grconvertX(0.44 + 0.002 * max(nchar(BF10t), nchar(BF01t)), 
                "ndc", "user")
        }
        
        if (max(nchar(BF10t), nchar(BF01t)) == 8) {
            xx <- grconvertX(0.44 + 0.003 * max(nchar(BF10t), nchar(BF01t)), 
                "ndc", "user")
        }
        
        if (max(nchar(BF10t), nchar(BF01t)) > 8) {
            xx <- grconvertX(0.44 + 0.005 * max(nchar(BF10t), nchar(BF01t)), 
                "ndc", "user")
        }
        
        yy <- grconvertY(0.788 + offsetTopPart, "ndc", "user")
        
        # make sure that colored area is centered
        radius <- 0.06 * diff(range(xticks))
        A <- radius^2 * pi
        alpha <- 2/(BF01 + 1) * A/radius^2
        startpos <- pi/2 - alpha/2
        
        # draw probability wheel
        plotrix::floating.pie(xx, yy, c(BF10, 1), radius = radius, col = c("darkred", 
            "white"), lwd = 2, startpos = startpos)
        
        yy <- grconvertY(0.865 + offsetTopPart, "ndc", "user")
        yy2 <- grconvertY(0.708 + offsetTopPart, "ndc", "user")
        
        if (oneSided == FALSE) {
            
            text(xx, yy, "data|H1", cex = cexCI)
            text(xx, yy2, "data|H0", cex = cexCI)
        }
        
        if (oneSided == "right") {
            
            text(xx, yy, "data|H+", cex = cexCI)
            text(xx, yy2, "data|H0", cex = cexCI)
        }
        
        if (oneSided == "left") {
            
            text(xx, yy, "data|H-", cex = cexCI)
            text(xx, yy2, "data|H0", cex = cexCI)
        }
        
        # add legend
        CIText <- paste("95% CI: [", bquote(.(formatC(CIlow, 3, format = "f"))), 
            " ; ", bquote(.(formatC(CIhigh, 3, format = "f"))), "]", sep = "")
        
        medianLegendText <- paste("median =", medianText)
    }
    
    mostPosterior <- mean(delta > mean(range(xticks)))
    
    if (mostPosterior >= 0.5) {
        
        legendPosition <- min(xticks)
        legend(legendPosition, max(yticks), legend = c("Posterior", "Prior"), 
            lty = c(1, 3), bty = "n", lwd = c(lwd, lwd), cex = cexLegend, 
            xjust = 0, yjust = 1, x.intersp = 0.6, seg.len = 1.2)
    } else {
        
        legendPosition <- max(xticks)
        legend(legendPosition, max(yticks), legend = c("Posterior", "Prior"), 
            lty = c(1, 3), bty = "n", lwd = c(lwd, lwd), cex = cexLegend, 
            xjust = 1, yjust = 1, x.intersp = 0.6, seg.len = 1.2)
    }
}

### generate data ###

set.seed(1)
x <- rnorm(30, 0.15)

### calculate Bayes factor ###

library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)

### plot ###

.plotPosterior.ttest(x = x, rscale = "medium", BF = BF)

11.3 Robustness Check

This JASP graph shows the results of a Bayes factor robustness check. Note the second y-axis, the balance of the graphical elements, and the font size.

Show R-Code
library(BayesFactor)

.plotBF.robustnessCheck.ttest <- function(x = NULL, y = NULL, paired = FALSE, 
    BF10post, formula = NULL, data = NULL, rscale = 1, oneSided = FALSE, 
    lwd = 2, cexPoints = 1.4, cexAxis = 1.2, cexYXlab = 1.5, cexText = 1.2, 
    cexLegend = 1.4, lwdAxis = 1.2, cexEvidence = 1.6, BFH1H0 = TRUE, 
    dontPlotData = FALSE) {
    
    
    #### settings ####
    if (rscale == "medium") {
        r <- sqrt(2)/2
    }
    if (rscale == "wide") {
        r <- 1
    }
    if (rscale == "ultrawide") {
        r <- sqrt(2)
    }
    if (mode(rscale) == "numeric") {
        r <- rscale
    }
    
    if (oneSided == FALSE) {
        nullInterval <- NULL
    }
    if (oneSided == "right") {
        nullInterval <- c(0, Inf)
    }
    if (oneSided == "left") {
        nullInterval <- c(-Inf, 0)
    }
    
    
    par(mar = c(5, 6, 6, 7) + 0.1, las = 1)
    
    if (dontPlotData) {
        
        plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE, 
            xlab = "", ylab = "")
        
        axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            xlab = "")
        axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            ylab = "")
        
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            }
        }
        
        mtext("Cauchy prior width", side = 1, cex = cexYXlab, line = 2.5)
        
        return()
    }
    
    #### get BFs ###
    rValues <- seq(0.0005, 1.5, length.out = 400)
    
    # BF10
    BF10 <- vector("numeric", length(rValues))
    
    for (i in seq_along(rValues)) {
        
        if (oneSided == FALSE) {
            
            BF <- BayesFactor::ttestBF(x = x, y = y, paired = paired, 
                nullInterval = nullInterval, rscale = rValues[i])
            BF10[i] <- BayesFactor::extractBF(BF, logbf = FALSE, onlybf = F)[1, 
                "bf"]
            
        } else {
            
            BF10[i] <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired, 
                oneSided = oneSided, r = rValues[i])
        }
        
    }
    
    # BF10 'medium' prior
    if (oneSided == FALSE) {
        
        BF10m <- BayesFactor::ttestBF(x = x, y = y, paired = paired, nullInterval = nullInterval, 
            rscale = "medium")
        BF10m <- BayesFactor::extractBF(BF10m, logbf = FALSE, onlybf = F)[1, 
            "bf"]
        
    } else {
        
        BF10m <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired, 
            oneSided = oneSided, r = "medium")
    }
    
    BF10mText <- BF10m
    
    # BF10 'wide' prior
    if (oneSided == FALSE) {
        
        BF10w <- BayesFactor::ttestBF(x = x, y = y, paired = paired, nullInterval = nullInterval, 
            rscale = "wide")
        BF10w <- BayesFactor::extractBF(BF10w, logbf = FALSE, onlybf = F)[1, 
            "bf"]
        
    } else {
        
        BF10w <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired, 
            oneSided = oneSided, r = "wide")
    }
    
    BF10wText <- BF10w
    
    # BF10 'ultrawide' prior
    if (oneSided == FALSE) {
        
        BF10ultra <- BayesFactor::ttestBF(x = x, y = y, paired = paired, 
            nullInterval = nullInterval, rscale = "ultrawide")
        BF10ultra <- BayesFactor::extractBF(BF10ultra, logbf = FALSE, 
            onlybf = F)[1, "bf"]
        
    } else {
        
        BF10ultra <- .oneSidedTtestBFRichard(x = x, y = y, paired = paired, 
            oneSided = oneSided, r = "ultrawide")
    }
    
    BF10ultraText <- BF10ultra
    
    # BF10 user prior
    BF10user <- BF10post
    BF10userText <- BF10user
    
    ####################### scale y axis ###########################
    
    BF <- c(BF10, BF10m, BF10w, BF10ultra, BF10user)
    
    if (!BFH1H0) {
        
        BF <- 1/BF
        BF10 <- 1/BF10
        BF10m <- 1/BF10m
        BF10w <- 1/BF10w
        BF10ultra <- 1/BF10ultra
        # BF10user <- 1 / BF10user
    }
    
    # y-axis labels larger than 1
    y1h <- "1"
    i <- 1
    
    while (eval(parse(text = y1h[i])) < max(BF10)) {
        
        if (grepl(pattern = "e", y1h[i])) {
            
            newy <- paste(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y1h[i], "0", sep = "")
        }
        
        if (eval(parse(text = newy)) >= 10^6) {
            
            newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
        }
        
        y1h <- c(y1h, newy)
        i <- i + 1
    }
    
    y3h <- "3"
    i <- 1
    
    while (eval(parse(text = y3h[i])) < max(BF10)) {
        
        if (grepl(pattern = "e", y3h[i])) {
            
            newy <- paste(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y3h[i], "0", sep = "")
        }
        
        if (as.numeric(newy) >= 10^6) {
            
            newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
        }
        
        y3h <- c(y3h, newy)
        i <- i + 1
    }
    
    yhigh <- vector("numeric", length(y1h) + length(y3h))
    o <- 1
    e <- 1
    
    for (i in seq_along(yhigh)) {
        
        if (i%%2 == 1) {
            
            yhigh[i] <- y1h[o]
            o <- o + 1
        }
        
        if (i%%2 == 0) {
            
            yhigh[i] <- y3h[e]
            e <- e + 1
        }
    }
    
    yhighLab <- as.character(yhigh)
    
    # y-axis labels smaller than 1
    y1l <- "1/1"
    i <- 1
    
    while (eval(parse(text = y1l[i])) > min(BF10)) {
        
        if (grepl(pattern = "e", y1l[i])) {
            
            newy <- paste(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y1l[i], "0", sep = "")
        }
        
        if (eval(parse(text = newy)) <= 10^(-6)) {
            
            newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            newy <- sub("-", "+", x = newy)
            newy <- paste0("1/", newy)
        }
        
        y1l <- c(y1l, newy)
        i <- i + 1
    }
    
    y3l <- "1/3"
    i <- 1
    
    while (eval(parse(text = y3l[i])) > min(BF10)) {
        
        if (grepl(pattern = "e", y3l[i])) {
            
            newy <- paste(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y3l[i], "0", sep = "")
        }
        
        if (newy == "1/3e+9") {
            newy <- "1/3e+09"
        }
        
        if (eval(parse(text = newy)) <= 10^(-6) & eval(parse(text = newy)) > 
            10^(-9)) {
            
            newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            newy <- paste(substring(newy, 1, nchar(newy) - 1), as.numeric(substring(newy, 
                nchar(newy), nchar(newy))) - 1, sep = "")
            newy <- sub(".33", "", newy)
            newy <- sub("-", "+", x = newy)
            newy <- paste0("1/", newy)
        }
        
        y3l <- c(y3l, newy)
        i <- i + 1
    }
    
    ylow <- vector("numeric", length(y1l) + length(y3l))
    o <- 1
    e <- 1
    
    for (i in seq_along(ylow)) {
        
        if (i%%2 == 1) {
            ylow[i] <- y1l[o]
            o <- o + 1
        }
        if (i%%2 == 0) {
            ylow[i] <- y3l[e]
            e <- e + 1
        }
    }
    
    yLab <- c(rev(ylow[-1]), yhighLab)
    
    # remove 3's if yLab vector is too long
    omit3s <- FALSE
    
    if (length(yLab) > 9) {
        
        omit3s <- TRUE
        
        ind <- which(yLab == "3")
        
        yLabsHigh <- yLab[ind:length(yLab)]
        
        if (length(yLabsHigh) > 1) {
            
            yLabsHigh <- yLabsHigh[seq(2, length(yLabsHigh), 2)]
        } else {
            
            yLabsHigh <- character(0)
        }
        
        yLabsLow <- yLab[1:(ind - 1)]
        yLabsLow <- yLabsLow[-grep(pattern = "/3", x = yLab)]
        
        yLab1s <- c(yLabsLow, yLabsHigh)
        
        if (max(BF10) > eval(parse(text = yLab1s[length(yLab1s)]))) {
            
            for (i in 1:2) {
                
                if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
                  
                  newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+", 
                    fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)], 
                    split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
                } else {
                  
                  newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
                }
                
                if (eval(parse(text = newy)) >= 10^6) {
                  
                  newy <- format(eval(parse(text = newy)), digits = 3, 
                    scientific = TRUE)
                }
                
                yLab1s <- c(yLab1s, newy)
            }
        }
        
        if (max(BF10) > eval(parse(text = yLab1s[length(yLab1s) - 1]))) {
            
            if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
                
                newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+", 
                  fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)], 
                  split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
            } else {
                
                newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
            }
            
            if (eval(parse(text = newy)) >= 10^6) {
                
                newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            }
            
            yLab1s <- c(yLab1s, newy)
        }
        
        if (yLab1s[1] == "1") {
            
            yLab1s <- c(paste0(yLab1s[1], "/", "10"), yLab1s)
        }
        if (yLab1s[length(yLab1s)] == "1") {
            
            yLab1s <- c(yLab1s, "10")
        }
        
        if (min(BF10) < eval(parse(text = yLab1s[1]))) {
            
            for (i in 1:2) {
                
                if (grepl(pattern = "e", yLab1s[1])) {
                  
                  newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1], 
                    "+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) + 
                      1, sep = "")
                } else {
                  
                  newy <- paste(yLab1s[1], "0", sep = "")
                }
                
                if (eval(parse(text = newy)) <= 10^(-6)) {
                  
                  newy <- format(eval(parse(text = newy)), digits = 3, 
                    scientific = TRUE)
                  newy <- sub("-", "+", x = newy)
                  newy <- substring(newy, nchar(newy) - 4, nchar(newy))
                  newy <- paste0("1/", newy)
                }
            }
            
            yLab1s <- c(newy, yLab1s)
        }
        
        if (min(BF10) < eval(parse(text = yLab1s[2]))) {
            
            if (grepl(pattern = "e", yLab1s[1])) {
                
                newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1], 
                  "+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) + 
                    1, sep = "")
            } else {
                
                newy <- paste(yLab1s[1], "0", sep = "")
            }
            
            if (eval(parse(text = newy)) <= 10^(-6)) {
                
                newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
                newy <- sub("-", "+", x = newy)
                newy <- substring(newy, nchar(newy) - 4, nchar(newy))
                newy <- paste0("1/", newy)
            }
            
            
            yLab1s <- c(newy, yLab1s)
        }
        
        yLab <- yLab1s
    }
    
    while (length(yLab) > 9) {
        
        ind <- which(yLab == "1")
        
        if (ind == 1) {
            
            yLabLow <- character(0)
        } else {
            
            yLabLow <- yLab[1:(ind - 1)]
        }
        
        if (ind == length(yLab)) {
            
            yLabHigh <- character(0)
        } else {
            
            yLabHigh <- yLab[(ind + 1):length(yLab)]
        }
        
        if (length(yLabLow) > 1) {
            
            yLabLow <- yLabLow[seq(length(yLabLow) - 1, 1, -2)]
        } else {
            
            yLabLow <- yLabLow
        }
        
        
        if (length(yLabHigh) > 1) {
            
            yLabHigh <- yLabHigh[seq(2, length(yLabHigh), 2)]
        } else {
            
            yLabHigh <- yLabHigh
        }
        
        if (length(yLabLow) == 1) {
            
            yLabLow <- paste("1/", yLabHigh[1], sep = "")
        }
        if (length(yLabHigh) == 1) {
            
            yLabHigh <- strsplit(x = yLabLow[1], "/", fixed = TRUE)[[1]][2]
        }
        
        yLab <- c(rev(yLabLow), "1", yLabHigh)
    }
    
    while (eval(parse(text = yLab[2])) > min(BF10)) {
        
        interval <- as.numeric(strsplit(format(eval(parse(text = yLab[1])), 
            digits = 3, scientific = TRUE), "-", fixed = TRUE)[[1]][2]) - 
            as.numeric(strsplit(format(eval(parse(text = yLab[2])), digits = 3, 
                scientific = TRUE), "-", fixed = TRUE)[[1]][2])
        pot <- as.numeric(strsplit(format(eval(parse(text = yLab[1])), 
            digits = 3, scientific = TRUE), "-", fixed = TRUE)[[1]][2]) + 
            interval
        
        if (nchar(pot) == 1) 
            pot <- paste("0", pot, sep = "")
        
        newy <- paste("1/1e", "+", pot, sep = "")
        yLab <- c(newy, yLab)

    }
    
    
    while (eval(parse(text = yLab[length(yLab) - 1])) < max(BF10)) {
        
        interval <- as.numeric(strsplit(format(eval(parse(text = yLab[length(yLab)])), 
            digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][2]) - 
            as.numeric(strsplit(format(eval(parse(text = yLab[length(yLab) - 
                1])), digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][2])
        pot <- as.numeric(strsplit(format(eval(parse(text = yLab[length(yLab)])), 
            digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][2]) + 
            interval
        
        if (nchar(pot) == 1) 
            pot <- paste("0", pot, sep = "")
        
        newy <- paste(strsplit(format(eval(parse(text = yLab[length(yLab)])), 
            digits = 3, scientific = TRUE), "+", fixed = TRUE)[[1]][1], 
            "+", pot, sep = "")
        yLab <- c(yLab, newy)
    }
    
    
    yAt <- vector("numeric", length(yLab))
    
    for (i in seq_along(yLab)) {
        
        yAt[i] <- log(eval(parse(text = yLab[i])))
    }
    
    
    ####################### plot ###########################
    
    xLab <- c(0, 0.25, 0.5, 0.75, 1, 1.25, 1.5)
    xlim <- range(xLab)
    ylow <- log(eval(parse(text = yLab[1])))
    yhigh <- log(eval(parse(text = yLab[length(yLab)])))
    ylim <- c(ylow, yhigh)
    
    plot(1, 1, xlim = xlim, ylim = ylim, ylab = "", xlab = "", type = "n", 
        axes = FALSE)
    
    
    for (i in seq_along(yAt)) {
        
        lines(x = xlim, y = rep(yAt[i], 2), col = "darkgrey", lwd = 1.3, 
            lty = 2)
    }
    
    lines(xlim, rep(0, 2), lwd = lwd)
    
    axis(1, at = xLab, labels = xLab, cex.axis = cexAxis, lwd = lwdAxis)
    axis(2, at = yAt, labels = yLab, cex.axis = cexAxis, lwd = lwdAxis)
    
    # enable plotting in margin
    par(xpd = TRUE)
    xx <- grconvertX(0.79, "ndc", "user")
    
    yAthigh <- yAt[yAt >= 0]
    
    if (!omit3s & eval(parse(text = yLab[1])) >= 1/300 & eval(parse(text = yLab[length(yLab)])) <= 
        300) {
        
        for (i in 1:(length(yAthigh) - 1)) {
            yy <- mean(c(yAthigh[i], yAthigh[i + 1]))
            
            if (yAthigh[i] == log(1)) {
                text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(3)) {
                text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(10)) {
                text(x = xx, yy, "Strong", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(30)) {
                text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(100)) {
                text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
            }
        }
        
        yAtlow <- rev(yAt[yAt <= 0])
        
        for (i in 1:(length(yAtlow) - 1)) {
            
            yy <- mean(c(yAtlow[i], yAtlow[i + 1]))
            
            if (yAtlow[i] == log(1)) {
                text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/3)) {
                text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/10)) {
                text(x = xx, yy, "Strong", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/30)) {
                text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/100)) {
                text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
            }
        }
        
        axis(side = 4, at = yAt, tick = TRUE, las = 2, cex.axis = cexAxis, 
            lwd = lwdAxis, labels = FALSE, line = -0.6)
        
        xx <- grconvertX(0.96, "ndc", "user")
        yy <- grconvertY(0.5, "npc", "user")
        text(xx, yy, "Evidence", srt = -90, cex = cexEvidence)
    }
    
    if (omit3s) {
        
        if (eval(parse(text = yLab[1])) <= 1/10^6) {
            
            line <- 4.75
            
        } else {
            
            line <- 4.3
        }
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = line)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYXlab, line = line)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = line)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYXlab, line = line)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = line)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYXlab, line = line)
            }
        }
    }
    
    if (omit3s == FALSE) {
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYXlab, line = 3.1)
            }
        }
    }
    
    mtext("Cauchy prior width", side = 1, cex = cexYXlab, line = 2.5)
    
    xx <- grconvertX(0.1, "npc", "user")
    yy1 <- yAt[length(yAt) - 1]
    yy2 <- yAt[length(yAt)]
    yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
    yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
    
    arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
    
    xxt <- grconvertX(0.28, "npc", "user")
    
    if (oneSided == FALSE) {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    if (oneSided == "right") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    if (oneSided == "left") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    yy1 <- yAt[2]
    yy2 <- yAt[1]
    yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
    yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
    
    arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
    
    if (oneSided == FALSE) {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1", 
                cex = cexText)
        }
    }
    
    if (oneSided == "right") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+", 
                cex = cexText)
        }
    }
    
    if (oneSided == "left") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-", 
                cex = cexText)
        }
    }
    
    # display BF10
    lines(rValues, log(BF10), col = "black", lwd = 2.7)
    
    # display 'wide', user, and 'ultrawide' prior BFs
    points(r, log(BF10user), pch = 21, bg = "grey", cex = cexPoints, lwd = 1.3)  # user prior
    points(1, log(BF10w), pch = 21, bg = "black", cex = 1.1, lwd = 1.3)  # 'wide' prior
    points(sqrt(2), log(BF10ultra), pch = 21, bg = "white", cex = 1.1, 
        lwd = 1.3)  # 'ultrawide' prior
    
    #### add legend BF values
    
    # BFuser
    
    if (BFH1H0) {
        
        BF01userText <- 1/BF10userText
        
    } else {
        
        BF10userText <- 1/BF10userText
        BF01userText <- 1/BF10userText
    }
    
    if (BF10userText >= 1000000 | BF01userText >= 1000000) {
        
        BF10usert <- format(BF10userText, digits = 4, scientific = TRUE)
        BF01usert <- format(BF01userText, digits = 4, scientific = TRUE)
    }
    if (BF10userText < 1000000 & BF01userText < 1000000) {
        
        BF10usert <- formatC(BF10userText, 3, format = "f")
        BF01usert <- formatC(BF01userText, 3, format = "f")
    }
    
    if (oneSided == FALSE) {
        
        if (BF10userText >= BF01userText) {
            userBF <- bquote(BF[10] == .(BF10usert))
        } else {
            userBF <- bquote(BF[0][1] == .(BF01usert))
        }
    }
    if (oneSided == "right") {
        
        if (BF10userText >= BF01userText) {
            userBF <- bquote(BF["+"][0] == .(BF10usert))
        } else {
            userBF <- bquote(BF[0]["+"] == .(BF01usert))
        }
    }
    if (oneSided == "left") {
        
        if (BF10userText >= BF01userText) {
            userBF <- bquote(BF["-"][0] == .(BF10usert))
        } else {
            userBF <- bquote(BF[0]["-"] == .(BF01usert))
        }
    }
    
    # BFwide
    BF01wText <- 1/BF10wText
    
    if (BF10wText >= 1000000 | BF01wText >= 1000000) {
        BF10wt <- format(BF10wText, digits = 4, scientific = TRUE)
        BF01wt <- format(BF01wText, digits = 4, scientific = TRUE)
    }
    if (BF10wText < 1000000 & BF01wText < 1000000) {
        BF10wt <- formatC(BF10wText, 3, format = "f")
        BF01wt <- formatC(BF01wText, 3, format = "f")
    }
    
    if (oneSided == FALSE) {
        
        if (BF10wText >= BF01wText) {
            wBF <- bquote(BF[10] == .(BF10wt))
        } else {
            wBF <- bquote(BF[0][1] == .(BF01wt))
        }
    }
    if (oneSided == "right") {
        
        if (BF10wText >= BF01wText) {
            wBF <- bquote(BF["+"][0] == .(BF10wt))
        } else {
            wBF <- bquote(BF[0]["+"] == .(BF01wt))
        }
    }
    if (oneSided == "left") {
        
        if (BF10wText >= BF01wText) {
            wBF <- bquote(BF["-"][0] == .(BF10wt))
        } else {
            wBF <- bquote(BF[0]["-"] == .(BF01wt))
        }
    }
    
    # BFultrawide
    BF01ultraText <- 1/BF10ultraText
    
    if (BF10ultraText >= 1000000 | BF01ultraText >= 1000000) {
        
        BF10ultrat <- format(BF10ultraText, digits = 4, scientific = TRUE)
        BF01ultrat <- format(BF01ultraText, digits = 4, scientific = TRUE)
    }
    if (BF10ultraText < 1000000 & BF01ultraText < 1000000) {
        
        BF10ultrat <- formatC(BF10ultraText, 3, format = "f")
        BF01ultrat <- formatC(BF01ultraText, 3, format = "f")
    }
    
    if (oneSided == FALSE) {
        
        if (BF10ultraText >= BF01ultraText) {
            ultraBF <- bquote(BF[10] == .(BF10ultrat))
        } else {
            ultraBF <- bquote(BF[0][1] == .(BF01ultrat))
        }
    }
    
    if (oneSided == "right") {
        
        if (BF10ultraText >= BF01ultraText) {
            ultraBF <- bquote(BF["+"][0] == .(BF10ultrat))
        } else {
            ultraBF <- bquote(BF[0]["+"] == .(BF01ultrat))
        }
    }
    
    if (oneSided == "left") {
        
        if (BF10ultraText >= BF01ultraText) {
            ultraBF <- bquote(BF["-"][0] == .(BF10ultrat))
        } else {
            ultraBF <- bquote(BF[0]["-"] == .(BF01ultrat))
        }
    }
    
    xx <- grconvertX(0.2, "ndc", "user")
    yy <- grconvertY(0.965, "ndc", "user")
    
    BFind <- sort(c(BF10userText, BF10ultraText, BF10wText), decreasing = TRUE, 
        index.return = TRUE)$ix
    BFsort <- sort(c(BF10userText, BF10ultraText, BF10wText), decreasing = TRUE, 
        index.return = TRUE)$x
    
    legend <- c("user prior:", "ultrawide prior:", "wide prior:")
    pt.bg <- c("grey", "white", "black")
    pt.cex <- c(cexPoints, 1.1, 1.1)
    
    legend(xx, yy, legend = legend[BFind], pch = rep(21, 3), pt.bg = pt.bg[BFind], 
        bty = "n", cex = cexLegend, lty = rep(NULL, 3), pt.lwd = rep(1.3, 
            3), pt.cex = pt.cex[BFind])
    
    xx <- grconvertX(0.5, "ndc", "user")
    y1 <- grconvertY(0.902, "ndc", "user")
    y2 <- grconvertY(0.852, "ndc", "user")
    y3 <- grconvertY(0.802, "ndc", "user")
    yy <- c(y1, y2, y3)
    
    text(xx, yy[BFsort == BF10userText], userBF, cex = 1.3, pos = 4)
    text(xx, yy[BFsort == BF10ultraText], ultraBF, cex = 1.3, pos = 4)
    text(xx, yy[BFsort == BF10wText], wBF, cex = 1.3, pos = 4)
}

### generate data ###

set.seed(1)
x <- rnorm(30, 0.15)

### calculate Bayes factor ###

library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)

### plot ###

.plotBF.robustnessCheck.ttest(x = x, BF10post = BF, rscale = "medium")

11.4 Evidential Flow

This graph shows the evidential flow, the fluctuations in the Bayes factor (y-axis) as the data accumulate (x-axis).

Show R-Code
library(BayesFactor)
library(plotrix)

.plotSequentialBF.ttest <- function(x = NULL, y = NULL, paired = FALSE, 
    BF10post, formula = NULL, data = NULL, rscale = 1, oneSided = FALSE, 
    lwd = 2, cexPoints = 1.4, cexAxis = 1.2, cexYlab = 1.5, cexXlab = 1.6, 
    cexTextBF = 1.4, cexText = 1.2, cexLegend = 1.2, cexEvidence = 1.6, 
    lwdAxis = 1.2, plotDifferentPriors = FALSE, BFH1H0 = TRUE, dontPlotData = FALSE, 
    level1 = NULL, level2 = NULL, subDataSet = NULL) {
    
    #### settings ####
    
    if (!plotDifferentPriors) {
        
        evidenceText <- TRUE
    } else {
        
        evidenceText <- FALSE
    }
    
    
    if (rscale == "medium") {
        
        r <- sqrt(2)/2
    }
    
    if (rscale == "wide") {
        
        r <- 1
    }
    
    if (rscale == "ultrawide") {
        
        r <- sqrt(2)
    }
    
    if (mode(rscale) == "numeric") {
        
        r <- rscale
    }
    
    
    if (oneSided == FALSE) {
        
        nullInterval <- NULL
    }
    
    if (oneSided == "right") {
        
        nullInterval <- c(0, Inf)
    }
    
    if (oneSided == "left") {
        
        nullInterval <- c(-Inf, 0)
    }
    
    
    par(mar = c(5.6, 6, 7, 7) + 0.1, las = 1)
    
    
    if (dontPlotData) {
        
        plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE, 
            xlab = "", ylab = "")
        
        axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            xlab = "")
        axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            ylab = "")
        
        mtext("n", side = 1, cex = cexXlab, line = 2.5)
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        return()
    }
    
    
    if (is.null(y) || paired) {
        
        BF10 <- vector("numeric", max(length(x), length(y)))
        BF10w <- vector("numeric", max(length(x), length(y)))
        BF10u <- vector("numeric", max(length(x), length(y)))
        
        idData <- 1
        
        if (is.null(y)) {
            
            ind <- which(x == x[1])
            idData <- sum((ind + 1) - (1:(length(ind))) == 1)
            
        } else {
            
            idData <- 1
            
            
            for (i in 2:(min(c(length(x), length(y))))) {
                
                previous <- c(x[i - 1], y[i - 1])
                
                if (all(c(x[i], y[i]) == previous)) {
                  
                  idData <- idData + 1
                  
                } else if (x[i] == y[i]) {
                  
                  idData <- idData + 1
                  
                } else {
                  
                  break
                }
            }
        }
        
        BF10[1:idData] <- 1
        BF10w[1:idData] <- 1
        BF10u[1:idData] <- 1
        
        
        if (idData < length(x)) {
            
            i <- idData + 1
            
        } else {
            
            i <- idData
            
        }
        
        if (idData < length(y)) {
            
            j <- idData + 1
            
        } else {
            
            j <- idData
            
        }
        
        k <- idData + 1
        
        
        while ((i <= length(x) | j <= length(y)) & k <= length(BF10)) {
            
            if (oneSided == FALSE) {
                
                BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired, 
                  rscale = r, nullInterval = nullInterval)
                BF10[k] <- BayesFactor::extractBF(BF, logbf = FALSE, onlybf = F)[1, 
                  "bf"]
                
            } else {
                
                BF10[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j], 
                  paired = paired, r = r, oneSided = oneSided)
            }
            
            k <- k + 1
            
            if (i < length(x)) {
                
                i <- i + 1
            }
            if (j < length(y)) {
                
                j <- j + 1
            }
        }
        
        
        BF10 <- BF10[is.finite(BF10)]
        
        if (plotDifferentPriors) {
            
            if (idData < length(x)) {
                
                i <- idData + 1
                
            } else {
                
                i <- idData
                
            }
            
            if (idData < length(y)) {
                
                j <- idData + 1
                
            } else {
                
                j <- idData
                
            }
            
            k <- idData + 1
            
            
            while ((i <= length(x) | j <= length(y)) & k <= length(BF10u)) {
                
                if (oneSided == FALSE) {
                  
                  BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired, 
                    rscale = "ultrawide", nullInterval = nullInterval)
                  BF10u[k] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                    onlybf = F)[1, "bf"]
                  
                } else {
                  
                  BF10u[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j], 
                    paired = paired, r = "ultrawide", oneSided = oneSided)
                }
                
                k <- k + 1
                
                if (i < length(x)) {
                  
                  i <- i + 1
                }
                if (j < length(y)) {
                  
                  j <- j + 1
                }
            }
            
            BF10u <- BF10u[is.finite(BF10u)]
            
            if (idData < length(x)) {
                
                i <- idData + 1
                
            } else {
                
                i <- idData
                
            }
            
            if (idData < length(y)) {
                
                j <- idData + 1
                
            } else {
                
                j <- idData
                
            }
            
            k <- idData + 1
            
            
            while ((i <= length(x) | j <= length(y)) & k <= length(BF10w)) {
                
                if (oneSided == FALSE) {
                  
                  BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired, 
                    rscale = "wide", nullInterval = nullInterval)
                  BF10w[k] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                    onlybf = F)[1, "bf"]
                  
                } else {
                  
                  BF10w[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j], 
                    paired = paired, r = "wide", oneSided = oneSided)
                }
                
                k <- k + 1
                
                if (i < length(x)) {
                  
                  i <- i + 1
                }
                if (j < length(y)) {
                  
                  j <- j + 1
                }
            }
            
            BF10w <- BF10w[is.finite(BF10w)]
            
        }
        
    } else if (!is.null(y) && !paired) {
        
        idData <- 1
        
        xx <- numeric()
        yy <- numeric()
        
        BF10 <- vector("numeric", nrow(subDataSet))
        BF10w <- vector("numeric", nrow(subDataSet))
        BF10u <- vector("numeric", nrow(subDataSet))
        
        for (i in seq_len(nrow(subDataSet))) {
            
            if (subDataSet[i, 2] == level1) {
                
                xx <- c(xx, subDataSet[i, 1])
                
            } else if (subDataSet[i, 2] == level2) {
                
                yy <- c(yy, subDataSet[i, 1])
                
            }
            
            if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || sd(yy) > 
                0)) {
                
                if (oneSided == FALSE) {
                  
                  BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired, 
                    rscale = r, nullInterval = nullInterval)
                  BF10[i] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                    onlybf = F)[1, "bf"]
                  
                } else if (oneSided == "right") {
                  
                  BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right", 
                    r = r)
                  
                } else if (oneSided == "left") {
                  
                  BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left", 
                    r = r)
                }
                
            } else {
                
                BF10[i] <- 1
            }
        }
        
        
        if (plotDifferentPriors) {
            
            xx <- numeric()
            yy <- numeric()
            
            for (i in seq_len(nrow(subDataSet))) {
                
                if (subDataSet[i, 2] == level1) {
                  
                  xx <- c(xx, subDataSet[i, 1])
                  
                } else if (subDataSet[i, 2] == level2) {
                  
                  yy <- c(yy, subDataSet[i, 1])
                  
                }
                
                if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || 
                  sd(yy) > 0)) {
                  
                  if (oneSided == FALSE) {
                    
                    BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired, 
                      rscale = "ultrawide", nullInterval = nullInterval)
                    BF10u[i] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                      onlybf = F)[1, "bf"]
                    
                  } else if (oneSided == "right") {
                    
                    BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right", 
                      r = "ultrawide")
                    
                  } else if (oneSided == "left") {
                    
                    BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left", 
                      r = "ultrawide")
                  }
                  
                } else {
                  
                  BF10u[i] <- 1
                }
            }
            
            xx <- numeric()
            yy <- numeric()
            
            for (i in seq_len(nrow(subDataSet))) {
                
                if (subDataSet[i, 2] == level1) {
                  
                  xx <- c(xx, subDataSet[i, 1])
                  
                } else if (subDataSet[i, 2] == level2) {
                  
                  yy <- c(yy, subDataSet[i, 1])
                  
                }
                
                if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || 
                  sd(yy) > 0)) {
                  
                  if (oneSided == FALSE) {
                    
                    BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired, 
                      rscale = "wide", nullInterval = nullInterval)
                    BF10w[i] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                      onlybf = F)[1, "bf"]
                    
                  } else if (oneSided == "right") {
                    
                    BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right", 
                      r = "wide")
                    
                  } else if (oneSided == "left") {
                    
                    BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left", 
                      r = "wide")
                  }
                  
                } else {
                  
                  BF10w[i] <- 1
                }
            }
        }
    }
    
    ####################### scale y axis ###########################
    
    if (plotDifferentPriors) {
        
        BF <- c(BF10, BF10u, BF10w)
        
    } else {
        
        BF <- BF10
        
    }
    
    
    if (!BFH1H0) {
        
        BF <- 1/BF
        BF10 <- 1/BF10
        
        if (plotDifferentPriors) {
            
            BF10u <- 1/BF10u
            BF10w <- 1/BF10w
        }
    }
    
    
    # y-axis labels larger than 1
    
    y1h <- "1"
    
    i <- 1
    
    while (eval(parse(text = y1h[i])) < max(BF)) {
        
        if (grepl(pattern = "e", y1h[i])) {
            
            newy <- paste(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y1h[i], "0", sep = "")
        }
        
        if (eval(parse(text = newy)) >= 10^6) {
            
            newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
        }
        
        y1h <- c(y1h, newy)
        i <- i + 1
    }
    
    
    y3h <- "3"
    
    i <- 1
    
    while (eval(parse(text = y3h[i])) < max(BF)) {
        
        if (grepl(pattern = "e", y3h[i])) {
            
            newy <- paste(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y3h[i], "0", sep = "")
        }
        
        if (as.numeric(newy) >= 10^6) {
            
            newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
        }
        
        y3h <- c(y3h, newy)
        
        i <- i + 1
    }
    
    yhigh <- vector("numeric", length(y1h) + length(y3h))
    
    o <- 1
    e <- 1
    
    for (i in seq_along(yhigh)) {
        
        if (i%%2 == 1) {
            
            yhigh[i] <- y1h[o]
            o <- o + 1
        }
        
        if (i%%2 == 0) {
            
            yhigh[i] <- y3h[e]
            e <- e + 1
        }
    }
    
    yhighLab <- as.character(yhigh)
    
    
    # y-axis labels smaller than 1
    
    y1l <- "1/1"
    
    i <- 1
    
    while (eval(parse(text = y1l[i])) > min(BF)) {
        
        if (grepl(pattern = "e", y1l[i])) {
            
            newy <- paste(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y1l[i], "0", sep = "")
        }
        
        if (eval(parse(text = newy)) <= 10^(-6)) {
            
            newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            newy <- sub("-", "+", x = newy)
            newy <- paste0("1/", newy)
        }
        
        y1l <- c(y1l, newy)
        i <- i + 1
    }
    
    
    y3l <- "1/3"
    
    i <- 1
    
    while (eval(parse(text = y3l[i])) > min(BF)) {
        
        if (grepl(pattern = "e", y3l[i])) {
            
            newy <- paste(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y3l[i], "0", sep = "")
        }
        
        if (newy == "1/3e+9") {
            
            newy <- "1/3e+09"
        }
        
        if (eval(parse(text = newy)) <= 10^(-6) & eval(parse(text = newy)) > 
            10^(-9)) {
            
            newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            newy <- paste(substring(newy, 1, nchar(newy) - 1), as.numeric(substring(newy, 
                nchar(newy), nchar(newy))) - 1, sep = "")
            newy <- sub(".33", "", newy)
            newy <- sub("-", "+", x = newy)
            newy <- paste0("1/", newy)
        }
        
        y3l <- c(y3l, newy)
        i <- i + 1
    }
    
    ylow <- vector("numeric", length(y1l) + length(y3l))
    o <- 1
    e <- 1
    
    for (i in seq_along(ylow)) {
        
        if (i%%2 == 1) {
            
            ylow[i] <- y1l[o]
            o <- o + 1
        }
        
        if (i%%2 == 0) {
            
            ylow[i] <- y3l[e]
            e <- e + 1
        }
    }
    
    yLab <- c(rev(ylow[-1]), yhighLab)
    
    
    # remove 3's if yLab vector is too long
    omit3s <- FALSE
    
    if (length(yLab) > 9) {
        
        omit3s <- TRUE
        
        ind <- which(yLab == "3")
        
        yLabsHigh <- yLab[ind:length(yLab)]
        
        if (length(yLabsHigh) > 1) {
            
            yLabsHigh <- yLabsHigh[seq(2, length(yLabsHigh), 2)]
        } else {
            
            yLabsHigh <- character(0)
        }
        
        yLabsLow <- yLab[1:(ind - 1)]
        yLabsLow <- yLabsLow[-grep(pattern = "/3", x = yLab)]
        
        yLab1s <- c(yLabsLow, yLabsHigh)
        
        
        if (max(BF) > eval(parse(text = yLab1s[length(yLab1s)]))) {
            
            for (i in 1:2) {
                
                if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
                  
                  newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+", 
                    fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)], 
                    split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
                } else {
                  
                  newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
                }
                
                if (eval(parse(text = newy)) >= 10^6) {
                  
                  newy <- format(eval(parse(text = newy)), digits = 3, 
                    scientific = TRUE)
                }
                
                yLab1s <- c(yLab1s, newy)
            }
        }
        
        
        if (yLab1s[1] == "1") {
            
            yLab1s <- c(paste0(yLab1s[1], "/", "10"), yLab1s)
        }
        
        if (yLab1s[length(yLab1s)] == "1") {
            
            yLab1s <- c(yLab1s, "10")
        }
        
        if (min(BF) < eval(parse(text = yLab1s[1]))) {
            
            for (i in 1:2) {
                
                if (grepl(pattern = "e", yLab1s[1])) {
                  
                  newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1], 
                    "+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) + 
                      1, sep = "")
                } else {
                  
                  newy <- paste(yLab1s[1], "0", sep = "")
                }
                
                if (eval(parse(text = newy)) <= 10^(-6)) {
                  
                  newy <- format(eval(parse(text = newy)), digits = 3, 
                    scientific = TRUE)
                  newy <- sub("-", "+", x = newy)
                  newy <- substring(newy, nchar(newy) - 4, nchar(newy))
                  newy <- paste0("1/", newy)
                }
            }
            
            yLab1s <- c(newy, yLab1s)
        }
        
        yLab <- yLab1s
    }
    
    while (length(yLab) > 9) {
        
        ind <- which(yLab == "1")
        
        if (ind == 1) {
            
            yLabLow <- character(0)
        } else {
            
            yLabLow <- yLab[1:(ind - 1)]
        }
        
        if (ind == length(yLab)) {
            
            yLabHigh <- character(0)
        } else {
            
            yLabHigh <- yLab[(ind + 1):length(yLab)]
        }
        
        if (length(yLabLow) > 1) {
            
            yLabLow <- yLabLow[seq(length(yLabLow) - 1, 1, -2)]
        } else {
            
            yLabLow <- yLabLow
        }
        
        
        if (length(yLabHigh) > 1) {
            
            yLabHigh <- yLabHigh[seq(2, length(yLabHigh), 2)]
        } else {
            
            yLabHigh <- yLabHigh
        }
        
        if (length(yLabLow) == 1) {
            
            yLabLow <- paste("1/", yLabHigh[1], sep = "")
        }
        
        if (length(yLabHigh) == 1) {
            
            yLabHigh <- strsplit(x = yLabLow[1], "/", fixed = TRUE)[[1]][2]
        }
        
        yLab <- c(rev(yLabLow), "1", yLabHigh)
    }
    
    
    while (eval(parse(text = yLab[1])) > min(BF)) {
        
        for (i in 1:2) {
            
            interval <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) - 
                as.numeric(strsplit(yLab[2], "+", fixed = TRUE)[[1]][2])
            pot <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) + 
                interval
            
            newy <- paste(strsplit(yLab[1], "+", fixed = TRUE)[[1]][1], 
                "+", pot, sep = "")
            yLab <- c(newy, yLab)
        }
    }
    
    while (eval(parse(text = yLab[length(yLab)])) < max(BF)) {
        
        for (i in 1:2) {
            
            interval <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) - 
                as.numeric(strsplit(yLab[length(yLab) - 1], "+", fixed = TRUE)[[1]][2])
            pot <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) + 
                interval
            newy <- paste(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][1], 
                "+", pot, sep = "")
            yLab <- c(yLab, newy)
        }
    }
    
    yAt <- vector("numeric", length(yLab))
    
    for (i in seq_along(yLab)) {
        
        yAt[i] <- log(eval(parse(text = yLab[i])))
    }
    
    
    ####################### plot ###########################
    
    xLab <- pretty(c(0, length(BF10) + 2))
    xlim <- range(xLab)
    ylow <- log(eval(parse(text = yLab[1])))
    yhigh <- log(eval(parse(text = yLab[length(yLab)])))
    
    if (is.infinite(yhigh)) {
        
        yhigh <- 1e+308
    }
    
    
    ylim <- c(ylow, yhigh)
    
    plot(1, 1, xlim = xlim, ylim = ylim, ylab = "", xlab = "", type = "n", 
        axes = FALSE)
    
    
    for (i in seq_along(yAt)) {
        
        lines(x = xlim, y = rep(yAt[i], 2), col = "darkgrey", lwd = 1.3, 
            lty = 2)
    }
    
    lines(xlim, rep(0, 2), lwd = lwd)
    
    axis(1, at = xLab, labels = xLab, cex.axis = cexAxis, lwd = lwdAxis)
    axis(2, at = yAt, labels = yLab, cex.axis = cexAxis, lwd = lwdAxis)
    
    # enable plotting in margin
    par(xpd = TRUE)
    xx <- grconvertX(0.79, "ndc", "user")
    
    yAthigh <- yAt[yAt >= 0]
    
    if (!omit3s & eval(parse(text = yLab[1])) >= 1/300 & eval(parse(text = yLab[length(yLab)])) <= 
        300) {
        
        for (i in 1:(length(yAthigh) - 1)) {
            yy <- mean(c(yAthigh[i], yAthigh[i + 1]))
            
            if (yAthigh[i] == log(1)) {
                text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(3)) {
                text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(10)) {
                text(x = xx, yy, "Strong", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(30)) {
                text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(100)) {
                text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
            }
        }
        
        yAtlow <- rev(yAt[yAt <= 0])
        
        for (i in 1:(length(yAtlow) - 1)) {
            
            yy <- mean(c(yAtlow[i], yAtlow[i + 1]))
            
            if (yAtlow[i] == log(1)) {
                text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/3)) {
                text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/10)) {
                text(x = xx, yy, "Strong", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/30)) {
                text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/100)) {
                text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
            }
        }
        
        axis(side = 4, at = yAt, tick = TRUE, las = 2, cex.axis = cexAxis, 
            lwd = lwdAxis, labels = FALSE, line = -0.6)
        
        xx <- grconvertX(0.96, "ndc", "user")
        yy <- grconvertY(0.5, "npc", "user")
        
        text(xx, yy, "Evidence", srt = -90, cex = cexEvidence)
    }
    
    if (omit3s) {
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            }
        }
    }
    
    if (omit3s == FALSE) {
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
    }
    
    mtext("n", side = 1, cex = cexXlab, line = 2.5)
    
    xx <- grconvertX(0.1, "npc", "user")
    yy1 <- yAt[length(yAt) - 1]
    yy2 <- yAt[length(yAt)]
    yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
    yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
    
    arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
    
    xxt <- grconvertX(0.28, "npc", "user")
    
    if (oneSided == FALSE) {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    if (oneSided == "right") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    if (oneSided == "left") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    
    yy1 <- yAt[2]
    yy2 <- yAt[1]
    yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
    yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
    
    arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
    
    if (oneSided == FALSE) {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1", 
                cex = cexText)
        }
    }
    
    if (oneSided == "right") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+", 
                cex = cexText)
        }
    }
    
    if (oneSided == "left") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-", 
                cex = cexText)
        }
    }
    
    
    # display BF10 value
    if (idData < length(BF10)) {
        
        BF10e <- BF10post
        
    } else {
        
        BF10e <- 1
    }
    
    if (BFH1H0) {
        
        BF01e <- 1/BF10e
        
    } else {
        
        BF01e <- BF10e
        BF10e <- 1/BF01e
    }
    
    # display BF10 value
    
    offsetTopPart <- 0.06
    
    xx <- min(xLab)
    yy <- grconvertY(0.75 + offsetTopPart, "ndc", "user")
    yy2 <- grconvertY(0.806 + offsetTopPart, "ndc", "user")
    
    if (BF10e >= 1000000 | BF01e >= 1000000) {
        
        BF10t <- formatC(BF10e, 3, format = "e")
        BF01t <- formatC(BF01e, 3, format = "e")
    }
    
    if (BF10e < 1000000 & BF01e < 1000000) {
        
        BF10t <- formatC(BF10e, 3, format = "f")
        BF01t <- formatC(BF01e, 3, format = "f")
    }
    
    if (oneSided == FALSE) {
        
        text(xx, yy2, bquote(BF[10] == .(BF10t)), cex = cexTextBF, pos = 4, 
            offset = -0.2)
        text(xx, yy, bquote(BF[0][1] == .(BF01t)), cex = cexTextBF, pos = 4, 
            offset = -0.2)
    }
    
    if (oneSided == "right") {
        
        text(xx, yy2, bquote(BF["+"][0] == .(BF10t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
        text(xx, yy, bquote(BF[0]["+"] == .(BF01t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
    }
    
    if (oneSided == "left") {
        
        text(xx, yy2, bquote(BF["-"][0] == .(BF10t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
        text(xx, yy, bquote(BF[0]["-"] == .(BF01t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
    }
    
    
    # probability wheel
    
    if (max(nchar(BF10t), nchar(BF01t)) <= 4) {
        xx <- grconvertX(0.44, "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 5) {
        xx <- grconvertX(0.44 + 0.001 * 5, "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 6) {
        xx <- grconvertX(0.44 + 0.001 * 6, "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 7) {
        xx <- grconvertX(0.44 + 0.002 * max(nchar(BF10t), nchar(BF01t)), 
            "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 8) {
        xx <- grconvertX(0.44 + 0.003 * max(nchar(BF10t), nchar(BF01t)), 
            "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) > 8) {
        xx <- grconvertX(0.445 + 0.005 * max(nchar(BF10t), nchar(BF01t)), 
            "ndc", "user")
    }
    
    yy <- grconvertY(0.788 + offsetTopPart, "ndc", "user")
    
    
    # make sure that colored area is centered
    
    radius <- grconvertX(0.2, "ndc", "user") - grconvertX(0.16, "ndc", 
        "user")
    A <- radius^2 * pi
    alpha <- 2/(BF01e + 1) * A/radius^2
    startpos <- pi/2 - alpha/2
    
    # draw probability wheel
    
    plotrix::floating.pie(xx, yy, c(BF10e, 1), radius = radius, col = c("darkred", 
        "white"), lwd = 2, startpos = startpos)
    
    yy <- grconvertY(0.865 + offsetTopPart, "ndc", "user")
    yy2 <- grconvertY(0.708 + offsetTopPart, "ndc", "user")
    
    if (oneSided == FALSE) {
        
        text(xx, yy, "data|H1", cex = 1.1)
        text(xx, yy2, "data|H0", cex = 1.1)
    }
    
    if (oneSided == "right") {
        
        text(xx, yy, "data|H+", cex = 1.1)
        text(xx, yy2, "data|H0", cex = 1.1)
    }
    
    if (oneSided == "left") {
        
        text(xx, yy, "data|H-", cex = 1.1)
        text(xx, yy2, "data|H0", cex = 1.1)
    }
    
    if (length(BF10) <= 60) {
        
        points(log(BF10), pch = 21, bg = "grey", cex = cexPoints, lwd = 1.3)  # user prior
    } else {
        
        lines(log(BF10), col = "black", lwd = 2.7)  # user prior
    }
    
    if (plotDifferentPriors) {
        
        if (length(BF10) <= 60) {
            
            points(log(BF10u), pch = 21, bg = "white", cex = 0.7, lwd = 1.3)  # 'ultrawide' prior
            points(log(BF10w), pch = 21, bg = "black", cex = 0.7, lwd = 1.3)  # 'wide' prior
            
        } else {
            
            greycol <- rgb(0, 0, 0, alpha = 0.95)
            greycol2 <- rgb(0, 0, 0, alpha = 0.5)
            lines(log(BF10u), col = greycol2, cex = 0.7, lwd = 1.3, lty = 1)  # 'ultrawide' prior
            lines(log(BF10w), col = greycol, cex = 0.7, lwd = 1.3, lty = 3)  # 'wide' prior
        }
    }
    
    BFevidence <- BF10e
    
    if (evidenceText) {
        
        if (BF10e < 1) {
            BFevidence <- 1/BF10e
        }
        if (BFevidence >= 1 & BFevidence <= 3) {
            lab <- "Anecdotal"
        }
        if (BFevidence > 3 & BFevidence <= 10) {
            lab <- "Moderate"
        }
        if (BFevidence > 10 & BFevidence <= 30) {
            lab <- "Strong"
        }
        if (BFevidence > 30 & BFevidence <= 100) {
            lab <- "Very strong"
        }
        if (BFevidence > 100) {
            lab <- "Extreme"
        }
        xxT <- max(xLab)
        yyT <- grconvertY(0.775 + offsetTopPart, "ndc", "user")
        
        if (BF10e >= 1) {
            
            if (oneSided == FALSE) {
                text(xxT, yyT, paste("Evidence for H1:\n", lab), cex = 1.4, 
                  pos = 2, offset = -0.2)
            }
            if (oneSided == "right") {
                text(xxT, yyT, paste("Evidence for H+:\n", lab), cex = 1.4, 
                  pos = 2, offset = -0.2)
            }
            if (oneSided == "left") {
                text(xxT, yyT, paste("Evidence for H-:\n", lab), cex = 1.4, 
                  pos = 2, offset = -0.2)
            }
        }
        
        if (BF10e < 1) {
            text(xxT, yyT, paste("Evidence for H0:\n", lab), cex = 1.4, 
                pos = 2, offset = -0.2)
        }
        
    } else {
        
        # add legend
        xx <- grconvertX(0.56, "ndc", "user")
        yy <- grconvertY(0.872 + offsetTopPart, "ndc", "user")
        
        BFind <- sort(c(BF10[length(x)], BF10u[length(x)], BF10w[length(x)]), 
            decreasing = TRUE, index.return = TRUE)$ix
        legend <- c("user prior", "ultrawide prior", "wide prior")
        
        if (length(BF10) <= 60) {
            
            pt.bg <- c("grey", "white", "black")
            pt.cex <- c(cexPoints, 0.7, 0.7)
            legend(xx, yy, legend = legend[BFind], pch = rep(21, 3), pt.bg = pt.bg[BFind], 
                bty = "n", cex = cexLegend, lty = rep(NULL, 3), pt.lwd = rep(1.3, 
                  3), pt.cex = pt.cex[BFind])
        } else {
            
            xx <- grconvertX(0.55, "ndc", "user")
            lty <- c(1, 1, 3)
            lwd <- c(2.7, 1.3, 1.3)
            col <- c("black", greycol2, greycol)
            legend(xx, yy, legend = legend[BFind], lty = lty[BFind], bty = "n", 
                cex = cexLegend, lwd = lwd[BFind], col = col[BFind], seg.len = 0.7)
        }
    }
}

### generate data ###

set.seed(1)
x <- rnorm(30, 0.15)

### calculate Bayes factor ###

library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)

### plot ###
.plotSequentialBF.ttest(x = x, BF10post = BF, rscale = "medium")

11.5 Evidential Flow with Robustness Check

The graph adds a robustness check by displying the evidential flow for different prior choices.

Show R-Code
library(BayesFactor)
library(plotrix)

.plotSequentialBF.ttest <- function(x = NULL, y = NULL, paired = FALSE, 
    BF10post, formula = NULL, data = NULL, rscale = 1, oneSided = FALSE, 
    lwd = 2, cexPoints = 1.4, cexAxis = 1.2, cexYlab = 1.5, cexXlab = 1.6, 
    cexTextBF = 1.4, cexText = 1.2, cexLegend = 1.2, cexEvidence = 1.6, 
    lwdAxis = 1.2, plotDifferentPriors = FALSE, BFH1H0 = TRUE, dontPlotData = FALSE, 
    level1 = NULL, level2 = NULL, subDataSet = NULL) {
    
    #### settings ####
    
    if (!plotDifferentPriors) {
        
        evidenceText <- TRUE
    } else {
        
        evidenceText <- FALSE
    }
    
    
    if (rscale == "medium") {
        
        r <- sqrt(2)/2
    }
    
    if (rscale == "wide") {
        
        r <- 1
    }
    
    if (rscale == "ultrawide") {
        
        r <- sqrt(2)
    }
    
    if (mode(rscale) == "numeric") {
        
        r <- rscale
    }
    
    
    if (oneSided == FALSE) {
        
        nullInterval <- NULL
    }
    
    if (oneSided == "right") {
        
        nullInterval <- c(0, Inf)
    }
    
    if (oneSided == "left") {
        
        nullInterval <- c(-Inf, 0)
    }
    
    
    par(mar = c(5.6, 6, 7, 7) + 0.1, las = 1)
    
    
    if (dontPlotData) {
        
        plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE, 
            xlab = "", ylab = "")
        
        axis(1, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            xlab = "")
        axis(2, at = 0:1, labels = FALSE, cex.axis = cexAxis, lwd = lwdAxis, 
            ylab = "")
        
        mtext("n", side = 1, cex = cexXlab, line = 2.5)
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        return()
    }
    
    
    if (is.null(y) || paired) {
        
        BF10 <- vector("numeric", max(length(x), length(y)))
        BF10w <- vector("numeric", max(length(x), length(y)))
        BF10u <- vector("numeric", max(length(x), length(y)))
        
        idData <- 1
        
        if (is.null(y)) {
            
            ind <- which(x == x[1])
            idData <- sum((ind + 1) - (1:(length(ind))) == 1)
            
        } else {
            
            idData <- 1
            
            
            for (i in 2:(min(c(length(x), length(y))))) {
                
                previous <- c(x[i - 1], y[i - 1])
                
                if (all(c(x[i], y[i]) == previous)) {
                  
                  idData <- idData + 1
                  
                } else if (x[i] == y[i]) {
                  
                  idData <- idData + 1
                  
                } else {
                  
                  break
                }
            }
        }
        
        BF10[1:idData] <- 1
        BF10w[1:idData] <- 1
        BF10u[1:idData] <- 1
        
        
        if (idData < length(x)) {
            
            i <- idData + 1
            
        } else {
            
            i <- idData
            
        }
        
        if (idData < length(y)) {
            
            j <- idData + 1
            
        } else {
            
            j <- idData
            
        }
        
        k <- idData + 1
        
        
        while ((i <= length(x) | j <= length(y)) & k <= length(BF10)) {
            
            if (oneSided == FALSE) {
                
                BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired, 
                  rscale = r, nullInterval = nullInterval)
                BF10[k] <- BayesFactor::extractBF(BF, logbf = FALSE, onlybf = F)[1, 
                  "bf"]
                
            } else {
                
                BF10[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j], 
                  paired = paired, r = r, oneSided = oneSided)
            }
            
            k <- k + 1
            
            if (i < length(x)) {
                
                i <- i + 1
            }
            if (j < length(y)) {
                
                j <- j + 1
            }
        }
        
        
        BF10 <- BF10[is.finite(BF10)]
        
        if (plotDifferentPriors) {
            
            if (idData < length(x)) {
                
                i <- idData + 1
                
            } else {
                
                i <- idData
                
            }
            
            if (idData < length(y)) {
                
                j <- idData + 1
                
            } else {
                
                j <- idData
                
            }
            
            k <- idData + 1
            
            
            while ((i <= length(x) | j <= length(y)) & k <= length(BF10u)) {
                
                if (oneSided == FALSE) {
                  
                  BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired, 
                    rscale = "ultrawide", nullInterval = nullInterval)
                  BF10u[k] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                    onlybf = F)[1, "bf"]
                  
                } else {
                  
                  BF10u[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j], 
                    paired = paired, r = "ultrawide", oneSided = oneSided)
                }
                
                k <- k + 1
                
                if (i < length(x)) {
                  
                  i <- i + 1
                }
                if (j < length(y)) {
                  
                  j <- j + 1
                }
            }
            
            BF10u <- BF10u[is.finite(BF10u)]
            
            if (idData < length(x)) {
                
                i <- idData + 1
                
            } else {
                
                i <- idData
                
            }
            
            if (idData < length(y)) {
                
                j <- idData + 1
                
            } else {
                
                j <- idData
                
            }
            
            k <- idData + 1
            
            
            while ((i <= length(x) | j <= length(y)) & k <= length(BF10w)) {
                
                if (oneSided == FALSE) {
                  
                  BF <- BayesFactor::ttestBF(x = x[1:i], y = y[1:j], paired = paired, 
                    rscale = "wide", nullInterval = nullInterval)
                  BF10w[k] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                    onlybf = F)[1, "bf"]
                  
                } else {
                  
                  BF10w[k] <- .oneSidedTtestBFRichard(x = x[1:i], y = y[1:j], 
                    paired = paired, r = "wide", oneSided = oneSided)
                }
                
                k <- k + 1
                
                if (i < length(x)) {
                  
                  i <- i + 1
                }
                if (j < length(y)) {
                  
                  j <- j + 1
                }
            }
            
            BF10w <- BF10w[is.finite(BF10w)]
            
        }
        
    } else if (!is.null(y) && !paired) {
        
        idData <- 1
        
        xx <- numeric()
        yy <- numeric()
        
        BF10 <- vector("numeric", nrow(subDataSet))
        BF10w <- vector("numeric", nrow(subDataSet))
        BF10u <- vector("numeric", nrow(subDataSet))
        
        for (i in seq_len(nrow(subDataSet))) {
            
            if (subDataSet[i, 2] == level1) {
                
                xx <- c(xx, subDataSet[i, 1])
                
            } else if (subDataSet[i, 2] == level2) {
                
                yy <- c(yy, subDataSet[i, 1])
                
            }
            
            if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || sd(yy) > 
                0)) {
                
                if (oneSided == FALSE) {
                  
                  BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired, 
                    rscale = r, nullInterval = nullInterval)
                  BF10[i] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                    onlybf = F)[1, "bf"]
                  
                } else if (oneSided == "right") {
                  
                  BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right", 
                    r = r)
                  
                } else if (oneSided == "left") {
                  
                  BF10[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left", 
                    r = r)
                }
                
            } else {
                
                BF10[i] <- 1
            }
        }
        
        
        if (plotDifferentPriors) {
            
            xx <- numeric()
            yy <- numeric()
            
            for (i in seq_len(nrow(subDataSet))) {
                
                if (subDataSet[i, 2] == level1) {
                  
                  xx <- c(xx, subDataSet[i, 1])
                  
                } else if (subDataSet[i, 2] == level2) {
                  
                  yy <- c(yy, subDataSet[i, 1])
                  
                }
                
                if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || 
                  sd(yy) > 0)) {
                  
                  if (oneSided == FALSE) {
                    
                    BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired, 
                      rscale = "ultrawide", nullInterval = nullInterval)
                    BF10u[i] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                      onlybf = F)[1, "bf"]
                    
                  } else if (oneSided == "right") {
                    
                    BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right", 
                      r = "ultrawide")
                    
                  } else if (oneSided == "left") {
                    
                    BF10u[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left", 
                      r = "ultrawide")
                  }
                  
                } else {
                  
                  BF10u[i] <- 1
                }
            }
            
            xx <- numeric()
            yy <- numeric()
            
            for (i in seq_len(nrow(subDataSet))) {
                
                if (subDataSet[i, 2] == level1) {
                  
                  xx <- c(xx, subDataSet[i, 1])
                  
                } else if (subDataSet[i, 2] == level2) {
                  
                  yy <- c(yy, subDataSet[i, 1])
                  
                }
                
                if (length(xx) > 1 && length(yy) > 1 && (sd(xx) > 0 || 
                  sd(yy) > 0)) {
                  
                  if (oneSided == FALSE) {
                    
                    BF <- BayesFactor::ttestBF(x = xx, y = yy, paired = paired, 
                      rscale = "wide", nullInterval = nullInterval)
                    BF10w[i] <- BayesFactor::extractBF(BF, logbf = FALSE, 
                      onlybf = F)[1, "bf"]
                    
                  } else if (oneSided == "right") {
                    
                    BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "right", 
                      r = "wide")
                    
                  } else if (oneSided == "left") {
                    
                    BF10w[i] <- .oneSidedTtestBFRichard(xx, yy, oneSided = "left", 
                      r = "wide")
                  }
                  
                } else {
                  
                  BF10w[i] <- 1
                }
            }
        }
    }
    
    ####################### scale y axis ###########################
    
    if (plotDifferentPriors) {
        
        BF <- c(BF10, BF10u, BF10w)
        
    } else {
        
        BF <- BF10
        
    }
    
    
    if (!BFH1H0) {
        
        BF <- 1/BF
        BF10 <- 1/BF10
        
        if (plotDifferentPriors) {
            
            BF10u <- 1/BF10u
            BF10w <- 1/BF10w
        }
    }
    
    
    # y-axis labels larger than 1
    
    y1h <- "1"
    
    i <- 1
    
    while (eval(parse(text = y1h[i])) < max(BF)) {
        
        if (grepl(pattern = "e", y1h[i])) {
            
            newy <- paste(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y1h[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y1h[i], "0", sep = "")
        }
        
        if (eval(parse(text = newy)) >= 10^6) {
            
            newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
        }
        
        y1h <- c(y1h, newy)
        i <- i + 1
    }
    
    
    y3h <- "3"
    
    i <- 1
    
    while (eval(parse(text = y3h[i])) < max(BF)) {
        
        if (grepl(pattern = "e", y3h[i])) {
            
            newy <- paste(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y3h[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y3h[i], "0", sep = "")
        }
        
        if (as.numeric(newy) >= 10^6) {
            
            newy <- format(as.numeric(newy), digits = 3, scientific = TRUE)
        }
        
        y3h <- c(y3h, newy)
        
        i <- i + 1
    }
    
    yhigh <- vector("numeric", length(y1h) + length(y3h))
    
    o <- 1
    e <- 1
    
    for (i in seq_along(yhigh)) {
        
        if (i%%2 == 1) {
            
            yhigh[i] <- y1h[o]
            o <- o + 1
        }
        
        if (i%%2 == 0) {
            
            yhigh[i] <- y3h[e]
            e <- e + 1
        }
    }
    
    yhighLab <- as.character(yhigh)
    
    
    # y-axis labels smaller than 1
    
    y1l <- "1/1"
    
    i <- 1
    
    while (eval(parse(text = y1l[i])) > min(BF)) {
        
        if (grepl(pattern = "e", y1l[i])) {
            
            newy <- paste(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y1l[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y1l[i], "0", sep = "")
        }
        
        if (eval(parse(text = newy)) <= 10^(-6)) {
            
            newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            newy <- sub("-", "+", x = newy)
            newy <- paste0("1/", newy)
        }
        
        y1l <- c(y1l, newy)
        i <- i + 1
    }
    
    
    y3l <- "1/3"
    
    i <- 1
    
    while (eval(parse(text = y3l[i])) > min(BF)) {
        
        if (grepl(pattern = "e", y3l[i])) {
            
            newy <- paste(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][1], 
                "+", as.numeric(strsplit(y3l[i], split = "+", fixed = TRUE)[[1]][2]) + 
                  1, sep = "")
        } else {
            
            newy <- paste(y3l[i], "0", sep = "")
        }
        
        if (newy == "1/3e+9") {
            
            newy <- "1/3e+09"
        }
        
        if (eval(parse(text = newy)) <= 10^(-6) & eval(parse(text = newy)) > 
            10^(-9)) {
            
            newy <- format(eval(parse(text = newy)), digits = 3, scientific = TRUE)
            newy <- paste(substring(newy, 1, nchar(newy) - 1), as.numeric(substring(newy, 
                nchar(newy), nchar(newy))) - 1, sep = "")
            newy <- sub(".33", "", newy)
            newy <- sub("-", "+", x = newy)
            newy <- paste0("1/", newy)
        }
        
        y3l <- c(y3l, newy)
        i <- i + 1
    }
    
    ylow <- vector("numeric", length(y1l) + length(y3l))
    o <- 1
    e <- 1
    
    for (i in seq_along(ylow)) {
        
        if (i%%2 == 1) {
            
            ylow[i] <- y1l[o]
            o <- o + 1
        }
        
        if (i%%2 == 0) {
            
            ylow[i] <- y3l[e]
            e <- e + 1
        }
    }
    
    yLab <- c(rev(ylow[-1]), yhighLab)
    
    
    # remove 3's if yLab vector is too long
    omit3s <- FALSE
    
    if (length(yLab) > 9) {
        
        omit3s <- TRUE
        
        ind <- which(yLab == "3")
        
        yLabsHigh <- yLab[ind:length(yLab)]
        
        if (length(yLabsHigh) > 1) {
            
            yLabsHigh <- yLabsHigh[seq(2, length(yLabsHigh), 2)]
        } else {
            
            yLabsHigh <- character(0)
        }
        
        yLabsLow <- yLab[1:(ind - 1)]
        yLabsLow <- yLabsLow[-grep(pattern = "/3", x = yLab)]
        
        yLab1s <- c(yLabsLow, yLabsHigh)
        
        
        if (max(BF) > eval(parse(text = yLab1s[length(yLab1s)]))) {
            
            for (i in 1:2) {
                
                if (grepl(pattern = "e", yLab1s[length(yLab1s)])) {
                  
                  newy <- paste(strsplit(yLab1s[length(yLab1s)], split = "+", 
                    fixed = TRUE)[[1]][1], "+", as.numeric(strsplit(yLab1s[length(yLab1s)], 
                    split = "+", fixed = TRUE)[[1]][2]) + 1, sep = "")
                } else {
                  
                  newy <- paste(yLab1s[length(yLab1s)], "0", sep = "")
                }
                
                if (eval(parse(text = newy)) >= 10^6) {
                  
                  newy <- format(eval(parse(text = newy)), digits = 3, 
                    scientific = TRUE)
                }
                
                yLab1s <- c(yLab1s, newy)
            }
        }
        
        
        if (yLab1s[1] == "1") {
            
            yLab1s <- c(paste0(yLab1s[1], "/", "10"), yLab1s)
        }
        
        if (yLab1s[length(yLab1s)] == "1") {
            
            yLab1s <- c(yLab1s, "10")
        }
        
        if (min(BF) < eval(parse(text = yLab1s[1]))) {
            
            for (i in 1:2) {
                
                if (grepl(pattern = "e", yLab1s[1])) {
                  
                  newy <- paste(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][1], 
                    "+", as.numeric(strsplit(yLab1s[1], split = "+", fixed = TRUE)[[1]][2]) + 
                      1, sep = "")
                } else {
                  
                  newy <- paste(yLab1s[1], "0", sep = "")
                }
                
                if (eval(parse(text = newy)) <= 10^(-6)) {
                  
                  newy <- format(eval(parse(text = newy)), digits = 3, 
                    scientific = TRUE)
                  newy <- sub("-", "+", x = newy)
                  newy <- substring(newy, nchar(newy) - 4, nchar(newy))
                  newy <- paste0("1/", newy)
                }
            }
            
            yLab1s <- c(newy, yLab1s)
        }
        
        yLab <- yLab1s
    }
    
    while (length(yLab) > 9) {
        
        ind <- which(yLab == "1")
        
        if (ind == 1) {
            
            yLabLow <- character(0)
        } else {
            
            yLabLow <- yLab[1:(ind - 1)]
        }
        
        if (ind == length(yLab)) {
            
            yLabHigh <- character(0)
        } else {
            
            yLabHigh <- yLab[(ind + 1):length(yLab)]
        }
        
        if (length(yLabLow) > 1) {
            
            yLabLow <- yLabLow[seq(length(yLabLow) - 1, 1, -2)]
        } else {
            
            yLabLow <- yLabLow
        }
        
        
        if (length(yLabHigh) > 1) {
            
            yLabHigh <- yLabHigh[seq(2, length(yLabHigh), 2)]
        } else {
            
            yLabHigh <- yLabHigh
        }
        
        if (length(yLabLow) == 1) {
            
            yLabLow <- paste("1/", yLabHigh[1], sep = "")
        }
        
        if (length(yLabHigh) == 1) {
            
            yLabHigh <- strsplit(x = yLabLow[1], "/", fixed = TRUE)[[1]][2]
        }
        
        yLab <- c(rev(yLabLow), "1", yLabHigh)
    }
    
    
    while (eval(parse(text = yLab[1])) > min(BF)) {
        
        for (i in 1:2) {
            
            interval <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) - 
                as.numeric(strsplit(yLab[2], "+", fixed = TRUE)[[1]][2])
            pot <- as.numeric(strsplit(yLab[1], "+", fixed = TRUE)[[1]][2]) + 
                interval
            
            newy <- paste(strsplit(yLab[1], "+", fixed = TRUE)[[1]][1], 
                "+", pot, sep = "")
            yLab <- c(newy, yLab)
        }
    }
    
    while (eval(parse(text = yLab[length(yLab)])) < max(BF)) {
        
        for (i in 1:2) {
            
            interval <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) - 
                as.numeric(strsplit(yLab[length(yLab) - 1], "+", fixed = TRUE)[[1]][2])
            pot <- as.numeric(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][2]) + 
                interval
            newy <- paste(strsplit(yLab[length(yLab)], "+", fixed = TRUE)[[1]][1], 
                "+", pot, sep = "")
            yLab <- c(yLab, newy)
        }
    }
    
    yAt <- vector("numeric", length(yLab))
    
    for (i in seq_along(yLab)) {
        
        yAt[i] <- log(eval(parse(text = yLab[i])))
    }
    
    
    ####################### plot ###########################
    
    xLab <- pretty(c(0, length(BF10) + 2))
    xlim <- range(xLab)
    ylow <- log(eval(parse(text = yLab[1])))
    yhigh <- log(eval(parse(text = yLab[length(yLab)])))
    
    if (is.infinite(yhigh)) {
        
        yhigh <- 1e+308
    }
    
    
    ylim <- c(ylow, yhigh)
    
    plot(1, 1, xlim = xlim, ylim = ylim, ylab = "", xlab = "", type = "n", 
        axes = FALSE)
    
    
    for (i in seq_along(yAt)) {
        
        lines(x = xlim, y = rep(yAt[i], 2), col = "darkgrey", lwd = 1.3, 
            lty = 2)
    }
    
    lines(xlim, rep(0, 2), lwd = lwd)
    
    axis(1, at = xLab, labels = xLab, cex.axis = cexAxis, lwd = lwdAxis)
    axis(2, at = yAt, labels = yLab, cex.axis = cexAxis, lwd = lwdAxis)
    
    # enable plotting in margin
    par(xpd = TRUE)
    xx <- grconvertX(0.79, "ndc", "user")
    
    yAthigh <- yAt[yAt >= 0]
    
    if (!omit3s & eval(parse(text = yLab[1])) >= 1/300 & eval(parse(text = yLab[length(yLab)])) <= 
        300) {
        
        for (i in 1:(length(yAthigh) - 1)) {
            yy <- mean(c(yAthigh[i], yAthigh[i + 1]))
            
            if (yAthigh[i] == log(1)) {
                text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(3)) {
                text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(10)) {
                text(x = xx, yy, "Strong", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(30)) {
                text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
            }
            if (yAthigh[i] == log(100)) {
                text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
            }
        }
        
        yAtlow <- rev(yAt[yAt <= 0])
        
        for (i in 1:(length(yAtlow) - 1)) {
            
            yy <- mean(c(yAtlow[i], yAtlow[i + 1]))
            
            if (yAtlow[i] == log(1)) {
                text(x = xx, yy, "Anecdotal", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/3)) {
                text(x = xx, yy, "Moderate", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/10)) {
                text(x = xx, yy, "Strong", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/30)) {
                text(x = xx, yy, "Very strong", pos = 4, cex = cexText)
            }
            if (yAtlow[i] == log(1/100)) {
                text(x = xx, yy, "Extreme", pos = 4, cex = cexText)
            }
        }
        
        axis(side = 4, at = yAt, tick = TRUE, las = 2, cex.axis = cexAxis, 
            lwd = lwdAxis, labels = FALSE, line = -0.6)
        
        xx <- grconvertX(0.96, "ndc", "user")
        yy <- grconvertY(0.5, "npc", "user")
        
        text(xx, yy, "Evidence", srt = -90, cex = cexEvidence)
    }
    
    if (omit3s) {
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYlab, line = 4.3)
            }
        }
    }
    
    if (omit3s == FALSE) {
        
        if (oneSided == FALSE) {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF[1][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0][1]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "right") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["+"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["+"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
        
        if (oneSided == "left") {
            
            if (BFH1H0) {
                
                mtext(text = expression(BF["-"][0]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            } else {
                
                mtext(text = expression(BF[0]["-"]), side = 2, las = 0, 
                  cex = cexYlab, line = 3.1)
            }
        }
    }
    
    mtext("n", side = 1, cex = cexXlab, line = 2.5)
    
    xx <- grconvertX(0.1, "npc", "user")
    yy1 <- yAt[length(yAt) - 1]
    yy2 <- yAt[length(yAt)]
    yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
    yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
    
    arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
    
    xxt <- grconvertX(0.28, "npc", "user")
    
    if (oneSided == FALSE) {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    if (oneSided == "right") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    if (oneSided == "left") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        }
    }
    
    
    yy1 <- yAt[2]
    yy2 <- yAt[1]
    yya1 <- yy1 + 1/4 * diff(c(yy1, yy2))
    yya2 <- yy1 + 3/4 * diff(c(yy1, yy2))
    
    arrows(xx, yya1, xx, yya2, length = 0.1, code = 2, lwd = lwd)
    
    if (oneSided == FALSE) {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H1", 
                cex = cexText)
        }
    }
    
    if (oneSided == "right") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H+", 
                cex = cexText)
        }
    }
    
    if (oneSided == "left") {
        
        if (BFH1H0) {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H0", 
                cex = cexText)
        } else {
            
            text(xxt, mean(c(yya1, yya2)), labels = "Evidence for H-", 
                cex = cexText)
        }
    }
    
    
    # display BF10 value
    if (idData < length(BF10)) {
        
        BF10e <- BF10post
        
    } else {
        
        BF10e <- 1
    }
    
    if (BFH1H0) {
        
        BF01e <- 1/BF10e
        
    } else {
        
        BF01e <- BF10e
        BF10e <- 1/BF01e
    }
    
    # display BF10 value
    
    offsetTopPart <- 0.06
    
    xx <- min(xLab)
    yy <- grconvertY(0.75 + offsetTopPart, "ndc", "user")
    yy2 <- grconvertY(0.806 + offsetTopPart, "ndc", "user")
    
    if (BF10e >= 1000000 | BF01e >= 1000000) {
        
        BF10t <- formatC(BF10e, 3, format = "e")
        BF01t <- formatC(BF01e, 3, format = "e")
    }
    
    if (BF10e < 1000000 & BF01e < 1000000) {
        
        BF10t <- formatC(BF10e, 3, format = "f")
        BF01t <- formatC(BF01e, 3, format = "f")
    }
    
    if (oneSided == FALSE) {
        
        text(xx, yy2, bquote(BF[10] == .(BF10t)), cex = cexTextBF, pos = 4, 
            offset = -0.2)
        text(xx, yy, bquote(BF[0][1] == .(BF01t)), cex = cexTextBF, pos = 4, 
            offset = -0.2)
    }
    
    if (oneSided == "right") {
        
        text(xx, yy2, bquote(BF["+"][0] == .(BF10t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
        text(xx, yy, bquote(BF[0]["+"] == .(BF01t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
    }
    
    if (oneSided == "left") {
        
        text(xx, yy2, bquote(BF["-"][0] == .(BF10t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
        text(xx, yy, bquote(BF[0]["-"] == .(BF01t)), cex = cexTextBF, 
            pos = 4, offset = -0.2)
    }
    
    
    # probability wheel
    
    if (max(nchar(BF10t), nchar(BF01t)) <= 4) {
        xx <- grconvertX(0.44, "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 5) {
        xx <- grconvertX(0.44 + 0.001 * 5, "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 6) {
        xx <- grconvertX(0.44 + 0.001 * 6, "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 7) {
        xx <- grconvertX(0.44 + 0.002 * max(nchar(BF10t), nchar(BF01t)), 
            "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) == 8) {
        xx <- grconvertX(0.44 + 0.003 * max(nchar(BF10t), nchar(BF01t)), 
            "ndc", "user")
    }
    
    if (max(nchar(BF10t), nchar(BF01t)) > 8) {
        xx <- grconvertX(0.445 + 0.005 * max(nchar(BF10t), nchar(BF01t)), 
            "ndc", "user")
    }
    
    yy <- grconvertY(0.788 + offsetTopPart, "ndc", "user")
    
    
    # make sure that colored area is centered
    
    radius <- grconvertX(0.2, "ndc", "user") - grconvertX(0.16, "ndc", 
        "user")
    A <- radius^2 * pi
    alpha <- 2/(BF01e + 1) * A/radius^2
    startpos <- pi/2 - alpha/2
    
    # draw probability wheel
    
    plotrix::floating.pie(xx, yy, c(BF10e, 1), radius = radius, col = c("darkred", 
        "white"), lwd = 2, startpos = startpos)
    
    yy <- grconvertY(0.865 + offsetTopPart, "ndc", "user")
    yy2 <- grconvertY(0.708 + offsetTopPart, "ndc", "user")
    
    if (oneSided == FALSE) {
        
        text(xx, yy, "data|H1", cex = 1.1)
        text(xx, yy2, "data|H0", cex = 1.1)
    }
    
    if (oneSided == "right") {
        
        text(xx, yy, "data|H+", cex = 1.1)
        text(xx, yy2, "data|H0", cex = 1.1)
    }
    
    if (oneSided == "left") {
        
        text(xx, yy, "data|H-", cex = 1.1)
        text(xx, yy2, "data|H0", cex = 1.1)
    }
    
    if (length(BF10) <= 60) {
        
        points(log(BF10), pch = 21, bg = "grey", cex = cexPoints, lwd = 1.3)  # user prior
    } else {
        
        lines(log(BF10), col = "black", lwd = 2.7)  # user prior
    }
    
    if (plotDifferentPriors) {
        
        if (length(BF10) <= 60) {
            
            points(log(BF10u), pch = 21, bg = "white", cex = 0.7, lwd = 1.3)  # 'ultrawide' prior
            points(log(BF10w), pch = 21, bg = "black", cex = 0.7, lwd = 1.3)  # 'wide' prior
            
        } else {
            
            greycol <- rgb(0, 0, 0, alpha = 0.95)
            greycol2 <- rgb(0, 0, 0, alpha = 0.5)
            lines(log(BF10u), col = greycol2, cex = 0.7, lwd = 1.3, lty = 1)  # 'ultrawide' prior
            lines(log(BF10w), col = greycol, cex = 0.7, lwd = 1.3, lty = 3)  # 'wide' prior
        }
    }
    
    BFevidence <- BF10e
    
    if (evidenceText) {
        
        if (BF10e < 1) {
            BFevidence <- 1/BF10e
        }
        if (BFevidence >= 1 & BFevidence <= 3) {
            lab <- "Anecdotal"
        }
        if (BFevidence > 3 & BFevidence <= 10) {
            lab <- "Moderate"
        }
        if (BFevidence > 10 & BFevidence <= 30) {
            lab <- "Strong"
        }
        if (BFevidence > 30 & BFevidence <= 100) {
            lab <- "Very strong"
        }
        if (BFevidence > 100) {
            lab <- "Extreme"
        }
        xxT <- max(xLab)
        yyT <- grconvertY(0.775 + offsetTopPart, "ndc", "user")
        
        if (BF10e >= 1) {
            
            if (oneSided == FALSE) {
                text(xxT, yyT, paste("Evidence for H1:\n", lab), cex = 1.4, 
                  pos = 2, offset = -0.2)
            }
            if (oneSided == "right") {
                text(xxT, yyT, paste("Evidence for H+:\n", lab), cex = 1.4, 
                  pos = 2, offset = -0.2)
            }
            if (oneSided == "left") {
                text(xxT, yyT, paste("Evidence for H-:\n", lab), cex = 1.4, 
                  pos = 2, offset = -0.2)
            }
        }
        
        if (BF10e < 1) {
            text(xxT, yyT, paste("Evidence for H0:\n", lab), cex = 1.4, 
                pos = 2, offset = -0.2)
        }
        
    } else {
        
        # add legend
        xx <- grconvertX(0.56, "ndc", "user")
        yy <- grconvertY(0.872 + offsetTopPart, "ndc", "user")
        
        BFind <- sort(c(BF10[length(x)], BF10u[length(x)], BF10w[length(x)]), 
            decreasing = TRUE, index.return = TRUE)$ix
        legend <- c("user prior", "ultrawide prior", "wide prior")
        
        if (length(BF10) <= 60) {
            
            pt.bg <- c("grey", "white", "black")
            pt.cex <- c(cexPoints, 0.7, 0.7)
            legend(xx, yy, legend = legend[BFind], pch = rep(21, 3), pt.bg = pt.bg[BFind], 
                bty = "n", cex = cexLegend, lty = rep(NULL, 3), pt.lwd = rep(1.3, 
                  3), pt.cex = pt.cex[BFind])
        } else {
            
            xx <- grconvertX(0.55, "ndc", "user")
            lty <- c(1, 1, 3)
            lwd <- c(2.7, 1.3, 1.3)
            col <- c("black", greycol2, greycol)
            legend(xx, yy, legend = legend[BFind], lty = lty[BFind], bty = "n", 
                cex = cexLegend, lwd = lwd[BFind], col = col[BFind], seg.len = 0.7)
        }
    }
}

### generate data ###

set.seed(1)
x <- rnorm(30, 0.15)

### calculate Bayes factor ###

library(BayesFactor)
BF <- extractBF(ttestBF(x, rscale = "medium"), onlybf = TRUE)

### plot ###
.plotSequentialBF.ttest(x = x, BF10post = BF, rscale = "medium", plotDifferentPriors = TRUE)

12 Miscellaneous

Several cool plots do not fall neatly into the above categories.

12.1 Funnel Plot

This is a funnel plot, and it is courtesy of Mark Nieuwenstein. The code depends on the meta and metafor R packages.

Show R-Code
library(meta)
library(metafor)

UT_CT <- structure(list(HedgesG = c(0.423967347, 0.463106494, 0.24028285, 0.859968212, 
    0.700832432, -0.47267567, 1.478756303, -0.0956, 0.3216, 0.246, -0.276444701, -0.0888, 
    -0.0883, 0.507049057, 0.2715, 0.4705, 0.3825, 0.172067039, -0.503812571, -0.373979221, 
    0.268963583, 0.338268088, 0.179899652, -0.559086162, -0.0901, 0.0688, -0.211118367, 
    1.212322358, 0.575640797, -0.345344262, 0.929063226, 0.997507389, -0.205137778, -0.25576051, 
    -0.498009871, -0.330754639, 0.624634361, 0.667445161, 0.626010596, 0.03, 0.089677431, 
    0.30608501, -0.365244026, -0.051468156, 0.27, 0.355, 0.775529648, 1.041749533, -0.096, 
    -0.143722066, 0.0953, -0.5481, 0.865, -0.738, -0.3701, -0.6209, 0.2206, 0, 0.43, 
    -0.008883176), SE = c(0.328686052, 0.26286584, 0.204602057, 0.333714062, 0.380311448, 
    0.250787154, 0.40690344, 0.155084096, 0.223830293, 0.156204994, 0.319656905, 0.318168825, 
    0.318166748, 0.315652397, 0.214242853, 0.221133444, 0.237907545, 0.293797292, 0.301387511, 
    0.261597221, 0.249257982, 0.328900502, 0.233733134, 0.206587525, 0.35614549, 0.200541797, 
    0.171667711, 0.269412515, 0.288276271, 0.292372285, 0.33215153, 0.293760287, 0.336350481, 
    0.211909603, 0.23109561, 0.247283673, 0.306012425, 0.257261725, 0.326419813, 0.316, 
    0.247090732, 0.248441017, 0.280785825, 0.355341625, 0.2749, 0.27, 0.289786359, 0.402131319, 
    0.160312195, 0.157579079, 0.32046, 0.450998, 0.6359, 0.476, 0.1857, 0.2022, 0.302, 
    0.2455, 0.3162, 0.100200227), InverseSE = c(3.042416897, 3.804221963, 4.887536399, 
    2.996577349, 2.629423875, 3.987445069, 2.457585512, 6.448114433, 4.467670516, 6.401843997, 
    3.128354129, 3.142985494, 3.143006003, 3.168041834, 4.66760028, 4.522156316, 4.203313517, 
    3.403707343, 3.317987517, 3.822670572, 4.011907632, 3.040433186, 4.278383572, 4.840563347, 
    2.807841257, 4.986491677, 5.825207274, 3.711780056, 3.468894601, 3.420296833, 3.010674074, 
    3.404136109, 2.973089248, 4.718993315, 4.327213305, 4.04393864, 3.267841172, 3.887092026, 
    3.063539526, 3.164556962, 4.047096352, 4.025100251, 3.561433345, 2.814193243, 3.637686431, 
    3.703703704, 3.450818054, 2.486749858, 6.237828616, 6.346020071, 3.120514261, 2.217304733, 
    1.572574304, 2.100840336, 5.385029618, 4.945598417, 3.311258278, 4.073319756, 3.162555345, 
    9.980017326), Ap = c(1L, 1L, 1L, 1L, 1L, 0L, 1L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 
    0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
    0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 1L, 0L, 0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
    0L, 0L, 0L), Blocked = c(0L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 1L, 0L, 0L, 0L, 
    0L, 1L, 1L, 0L, 0L, 0L, 0L, 1L, 0L, 1L, 0L, 0L, 1L, 1L, 1L, 0L, 0L, 0L, 0L, 0L, 0L, 
    0L, 1L, 1L, 999L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 0L, 0L, 0L, 1L, 1L, 1L, 1L, 1L, 999L, 
    0L, 1L, 0L, 1L, 1L), Complexity = c(48L, 60L, 36L, 48L, 48L, 48L, 48L, 48L, 48L, 
    30L, 48L, 48L, 48L, 48L, 48L, 48L, 48L, 40L, 40L, 48L, 48L, 60L, 48L, 48L, 48L, 48L, 
    48L, 108L, 108L, 36L, 48L, 48L, 48L, 48L, 48L, 48L, 48L, 48L, 160L, 48L, 48L, 36L, 
    44L, 48L, 144L, 144L, 48L, 36L, 48L, 40L, 48L, 48L, 48L, 75L, 48L, 48L, 96L, 48L, 
    48L, 48L), PresTime = c(4, 999, 2.5, 8, 8, 5, 4.5, 6, 4, 4, 8, 2, 999, 8, 8, 999, 
    999, 4, 999, 4, 8, 4, 8, 4, 8.8, 8.8, 999, 999, 999, 3.5, 7, 2.5, 2.5, 8, 8, 8, 10, 
    14, 999, 999, 999, 999, 999, 999, 4, 4, 4, 999, 4, 999, 4, 4, 4, 4, 999, 4, 999, 
    8, 4, 4), DelDur = c(3L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 3L, 3L, 4L, 4L, 
    4L, 4L, 4L, 8L, 4L, 4L, 4L, 4L, 3L, 4L, 4L, 3L, 3L, 3L, 4L, 5L, 4L, 4L, 4L, 4L, 4L, 
    3L, 3L, 5L, 4L, 4L, 4L, 4L, 4L, 4L, 4L, 3L, 999L, 4L, 3L, 3L, 3L, 3L, 3L, 5L, 3L, 
    3L, 4L, 3L, 3L), DistTask = c(3L, 3L, 1L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 4L, 1L, 1L, 
    1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 3L, 1L, 3L, 1L, 1L, 1L, 1L, 1L, 3L, 3L, 1L, 1L, 1L, 
    1L, 1L, 4L, 4L, 1L, 4L, 4L, 4L, 4L, 4L, 1L, 1L, 1L, 1L, 4L, 1L, 2L, 2L, 2L, 2L, 1L, 
    1L, 3L, 1L, 1L, 2L)), .Names = c("HedgesG", "SE", "InverseSE", "Ap", "Blocked", "Complexity", 
    "PresTime", "DelDur", "DistTask"), class = "data.frame", row.names = c(NA, -60L))

# Code for Trim and Fill procedure, to fill in missing effect sizes.
tf1 <- trimfill(UT_CT$HedgesG, UT_CT$SE)
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.3, bty = "n", las = 1)
funnel(tf1, yaxis = "invse", xlab = "", ylab = "", contour = 0.95, xlim = c(-2, 2), ylim = c(1, 
    12), cex = 2, col = "black", col.contour = "lightgray", ref = 0, axes = F)
axis(1)
axis(2)
par(las = 0)
mtext("Hedges' G", side = 1, line = 2.5, cex = 1.5)
mtext("Inverse of Standard Error", side = 2, line = 3, cex = 1.5)
par(op)

12.2 Network Graph

Sacha Epskamp uses his qgraph package and shows how to display a network with nodes and connections.

Show R-Code
library("psych")
library("qgraph")

# Load BFI data:
data(bfi)
bfi <- bfi[, 1:25]

# Groups and names object (not needed really, but make the plots easier to
# interpret):
Names <- scan("http://sachaepskamp.com/files/BFIitems.txt", what = "character", sep = "\n")

# Create groups object:
Groups <- rep(c("A", "C", "E", "N", "O"), each = 5)

# Compute correlations:
cor_bfi <- cor_auto(bfi)

# Plot correlation network:
graph_cor <- qgraph(cor_bfi, layout = "spring", nodeNames = Names, groups = Groups, legend.cex = 0.6, 
    DoNotPlot = TRUE)

# Plot partial correlation network:
graph_pcor <- qgraph(cor_bfi, graph = "concentration", layout = "spring", nodeNames = Names, 
    groups = Groups, legend.cex = 0.6, DoNotPlot = TRUE)

# Plot glasso network:
graph_glas <- qgraph(cor_bfi, graph = "glasso", sampleSize = nrow(bfi), layout = "spring", 
    nodeNames = Names, legend.cex = 0.6, groups = Groups, legend.cex = 0.7, GLratio = 2)

12.3 Questionnaire Graph

Sacha Epskamp shows how to present the many outcomes from a questionnaire in a single graph.

Show R-Code
library("psych")
library("qgraph")

# Load BFI data:
data(bfi)
bfi <- bfi[, 1:25]

# Groups and names object (not needed really, but make the plots easier to
# interpret):
Names <- scan("http://sachaepskamp.com/files/BFIitems.txt", what = "character", sep = "\n")

# Create groups object:
Groups <- rep(c("A", "C", "E", "N", "O"), each = 5)

# Compute correlations:
cor_bfi <- cor_auto(bfi)

# Plot correlation network:
graph_cor <- qgraph(cor_bfi, layout = "spring", nodeNames = Names, groups = Groups, legend.cex = 0.6, 
    DoNotPlot = TRUE)

# Plot partial correlation network:
graph_pcor <- qgraph(cor_bfi, graph = "concentration", layout = "spring", nodeNames = Names, 
    groups = Groups, legend.cex = 0.6, DoNotPlot = TRUE)

# Plot glasso network:
graph_glas <- qgraph(cor_bfi, graph = "glasso", sampleSize = nrow(bfi), layout = "spring", 
    nodeNames = Names, legend.cex = 0.6, groups = Groups, legend.cex = 0.7, GLratio = 2, 
    DoNotPlot = TRUE)
# centrality plot (all graphs):
centralityPlot(list(r = graph_cor, `Partial r` = graph_pcor, glasso = graph_glas), 
    labels = Names) + labs(colour = "") + theme_bw() + theme(legend.position = "bottom")

12.4 Heatmap with Contour Lines

This heatmap with contour lines displays the joint posterior for two variables.

Show R-Code
### All Priming likelihood surface with posterior of uniform mu prior on top

# MCMC samples
load("samplesAllPriming_uniformMuPrior_SigmaTruncatedOnlyAtOne.Rdata")
samples <- samplesAllPriming_uniformMuPrior_SigmaTruncatedOnlyAtOne
posteriorMu <- samples$BUGSoutput$sims.list$muH1
posteriorPhi <- samples$BUGSoutput$sims.list$phi

library(ks)
d1 <- kde(cbind(posteriorMu, posteriorPhi))

# logLikelihood3d
load("logLikelihood3d_allPriming.Rdata")

ll <- logLikelihood3d_allPriming

likelihood <- exp(ll + 100)

sumLikelihood <- sum(likelihood)
weights <- likelihood/sumLikelihood
likelihoodTimesWeights <- likelihood * weights
averagedLikelihood <- apply(likelihoodTimesWeights, c(1, 2), sum)

mu <- seq(-6, 0, length.out = 200)
phi <- seq(0, 1, length.out = 200)

op <- par(mar = c(5, 5, 5, 5))

image(x = mu, y = phi, z = averagedLikelihood, col = topo.colors(12), xlab = "", ylab = "", 
    las = 1, cex.axis = 1.4)

mtext(expression(mu), 1, cex = 2.2, line = 2.55)
mtext(expression(phi), 2, cex = 2.35, line = 3.3, las = 1)

contour(x = d1$eval.points[[1]], y = d1$eval.points[[2]], z = d1$estimate, add = TRUE, 
    lty = 1)

mtext(expression("Priming Studies (N=268)"), side = 3, cex = 2, line = 0.7)
par(op)

12.5 Nonparametric Bayes

This plot shows the results of a nonparametric Bayesian Dirichlet process mixture model analysis. The left panel displays the distribution of “active” groups during the MCMC iterations, the right panel visualizes which observations were assigned to the same group (lighter colors indicate higher probabilities of being in the same group).

Show R-Code
### plotting functions

.barplot <- function(column, variable, trueNgroups = 1, dontPlotData = FALSE) {
    
    if (dontPlotData) {
        
        plot(1, type = "n", xlim = 0:1, ylim = 0:1, bty = "n", axes = FALSE, xlab = "", 
            ylab = "")
        
        axis(1, at = 0:1, labels = FALSE, cex.axis = 1.4, xlab = "")
        axis(2, at = 0:1, labels = FALSE, cex.axis = 1.4, ylab = "")
        
        mtext(text = variable, side = 1, cex = 1.5, line = 3)
        
        return()
    }
    
    maxFrequency <- max(summary(column))
    
    i <- 1
    step <- 1
    
    while (maxFrequency/step > 9) {
        
        if (i == 2) {
            
            step <- 2 * step
            i <- i + 1
            
        } else if (i%%3 == 0) {
            
            step <- 2.5 * step
            i <- i + 1
            
        } else {
            
            step <- 2 * step
            i <- i + 1
        }
        
    }
    
    yticks <- 0
    
    while (yticks[length(yticks)] < maxFrequency) {
        
        yticks <- c(yticks, yticks[length(yticks)] + step)
    }
    
    
    yLabs <- vector("character", length(yticks))
    
    for (i in seq_along(yticks)) {
        
        if (yticks[i] < 10^6) {
            
            yLabs[i] <- format(yticks[i], digits = 3, scientific = FALSE)
            
        } else {
            
            yLabs[i] <- format(yticks[i], digits = 3, scientific = TRUE)
        }
    }
    
    distLab <- max(nchar(yLabs))/1.8
    
    par(mar = c(5, 7.2, 4, 2) + 0.1)
    nGroups <- barplot(summary(column), cex.names = 1.3, axes = FALSE, ylim = range(yticks), 
        plot = FALSE)
    col <- ifelse(seq_along(nGroups) == trueNgroups, "darkred", "grey")
    barplot(summary(column), cex.names = 1.3, axes = FALSE, ylim = range(yticks), col = col)
    axis(2, las = 1, at = yticks, labels = yLabs, cex.axis = 1.4)
    mtext(text = variable, side = 1, cex = 1.5, line = 3)
    mtext(text = "Frequency", side = 2, cex = 1.5, line = distLab + 2, las = 0)
}

plotCoocurrenceHeatMap <- function(coocurrenceProbs, offsetX = 0.3, offsetY = 0, cexXlab = 1.6, 
    cexYlab = 1.6, lwd = 4) {
    
    parameterLabel1 <- "Observations"
    parameterLabel2 <- "Observations"
    
    op <- par(mar = c(5, 6, 3, 4) + 0.1, las = 1)
    
    N <- ncol(coocurrenceProbs)
    
    xRange <- c(0, N)
    yRange <- c(0, N)
    
    image(x = seq_len(N), y = seq_len(N), z = t(coocurrenceProbs), col = topo.colors(12), 
        xlab = "", ylab = "", las = 1, cex.axis = 1.2)
    
    nRect <- N/50
    
    for (nr in seq_len(nRect)) {
        
        rect(1 + (nr - 1) * 50, 1 + (nr - 1) * 50, nr * 50, nr * 50, col = "darkred", 
            density = 0, lwd = lwd)
        
    }
    
    mtext(parameterLabel1, 1, cex = cexXlab, line = 2.5 + offsetX)
    mtext(parameterLabel2, 2, cex = cexYlab, line = 3.2 + offsetY, las = 0)
    
    par(op)
    
}

### 3 groups
load("samplesDPrecover3groups.Rdata")
load("coocurrenceProbs3.Rdata")

op <- par(mfrow = c(1, 2))

index3 <- paste("z[", seq_len(150), "]", sep = "")
zMatrix3 <- samplesDPrecover3groups$BUGSoutput$sims.matrix[, index3]
nGroupsPerIteration3 <- apply(zMatrix3, 1, function(x) length(unique(x)))
.barplot(as.factor(nGroupsPerIteration3), "Number of groups", trueNgroups = 1)

plotCoocurrenceHeatMap(coocurrenceProbs3)

par(op)

12.6 Confidence Band Plot

Courtesy of Liz Page-Gould, this plot shows how to plot a confidence band around a line.

Show R-Code
#### Create Data #### Data compiled by Allan J. Rossman (1994) from The World Almanac
#### and Book of Facts, 1993
#### (http://www.amstat.org/publications/jse/v2n2/datasets.rossman.html)
life.expectancy <- c(70.5, 53.5, 65, 76.5, 70, 71, 60.5, 51.5, 78, 76, 57.5, 61, 64.5, 
    78.5, 79, 61, 70, 70, 72, 64.5, 54.5, 56.5, 64.5, 64.5, 73, 72, 69, 64, 78.5, 53, 
    75, 68.5, 70, 70.5, 76, 75.5, 74.5, 65)
ppl.per.tv <- c(4, 315, 4, 1.7, 8, 5.6, 15, 503, 2.6, 2.6, 44, 24, 23, 3.8, 1.8, 96, 
    90, 4.9, 6.6, 21, 592, 73, 14, 8.8, 3.9, 6, 3.2, 11, 2.6, 23, 3.2, 11, 5, 3, 3, 1.3, 
    5.6, 29)
# Centre predictor so prediction interval estimates can be determined from the
# intercept and its SE
c.ppl.per.tv <- ppl.per.tv - mean(ppl.per.tv)

#### Run the Omnibus Linear Model ####
linear.model <- glm(life.expectancy ~ c.ppl.per.tv)

#### Create Plot Data (Predicted Values Using Omnibus Model) ####
x <- seq(from = 0, to = max(ppl.per.tv))
y <- array(NA, dim = length(x))
y.upper <- y
y.lower <- y
for (i in 1:length(x)) {
    raw.y <- coef(summary(update(linear.model, . ~ . - c.ppl.per.tv + eval(ppl.per.tv - 
        x[i]))))[1, 1]
    raw.se <- coef(summary(update(linear.model, . ~ . - c.ppl.per.tv + eval(ppl.per.tv - 
        x[i]))))[1, 2]
    y[i] <- raw.y
    y.upper[i] <- raw.y + raw.se
    y.lower[i] <- raw.y - raw.se
}

#### Create Plot ####
op <- par(cex.main = 1.5, mar = c(5, 6, 4, 5) + 0.1, mgp = c(3.5, 1, 0), cex.lab = 1.5, 
    font.lab = 2, cex.axis = 1.5, bty = "n", las = 1)
plot(x, y, xlab = "", ylab = "", type = "n", xlim = c(0, max(x)), ylim = c(40, 80), axes = FALSE)
axis(1)
axis(2)
polygon(c(x, rev(x)), c(y.upper, rev(y.lower)), col = "lightsteelblue", border = NA)
lines(x, y, lwd = 2)
mtext("People Per TV", side = 1, line = 2.5, cex = 1.5)
mtext("Life Expectancy", side = 2, line = 3.7, cex = 1.5, las = 0)

12.7 Many Intervals in One Plot

Courtesy of Felix Schönbrodt and Maarten Marsman, this plot shows credible intervals for each of 42 experiments in the Social Psychology special issue. Each experiment tried to replicate an important result in the field of social psychology.

Show R-Code
# rm (list = ls())

library(ggplot2)
clamp <- function(x, MIN, MAX) {
    if (x < MIN) 
        x <- MIN
    if (x > MAX) 
        x <- MAX
    x
}

# these contain the necessary labels
x <- read.csv("all3.csv", sep = ";", header = TRUE)
# these contain the numeric values
bf <- read.csv("all3_bfs.csv", sep = ";", header = TRUE)

ALL <- data.frame(study = as.character(x$Study1), HPD.median = bf$HPD.median, HPD.upper = bf$HPD.upper, 
    HPD.lower = bf$HPD.lower, logBF10 = bf$logBF10, logBF10_clamped = sapply(bf$logBF10, 
        function(lbf) {
            clamp(lbf, log(1/110), log(110))
        }), test = as.character(x$Testtype), number = as.integer(x[, 1]))

rm(x, bf, clamp)

# reorder factor levels based on another variable (HPD.mean)
ALL$study.ES_order <- reorder(ALL$study, ALL$HPD.median, mean)

### Effect size plot
p <- ggplot(ALL[!is.na(ALL$HPD.median), ], aes(x = study.ES_order, y = HPD.median, ymin = HPD.lower, 
    ymax = HPD.upper)) + geom_pointrange() + theme_bw() + coord_flip() + geom_hline(yintercept = 0, 
    linetype = "dotted") + ylab("Posterior Effect Size (Unrestricted)") + xlab("")
# Some HPD intervals are missing (NA): These pertain to ANOVAS and Contingency
# tables, where there are multiple parameters per test.
print(p)

12.8 Many Bayes Factors in One Plot

Courtesy of Felix Schönbrodt and Maarten Marsman, this plot is similar to the one above but now presents the Bayes factor instead of the credible interval.

Show R-Code
# rm(list = ls())

library(ggplot2)
clamp <- function(x, MIN, MAX) {
    if (x < MIN) 
        x <- MIN
    if (x > MAX) 
        x <- MAX
    x
}

# these contain the necessary labels
x <- read.csv("all3.csv", sep = ";", header = TRUE)
# these contain the numeric values
bf <- read.csv("all3_bfs.csv", sep = ";", header = TRUE)

ALL <- data.frame(study = as.character(x$Study1), HPD.median = bf$HPD.median, HPD.upper = bf$HPD.upper, 
    HPD.lower = bf$HPD.lower, logBF10 = bf$logBF10, logBF10_clamped = sapply(bf$logBF10, 
        function(lbf) {
            clamp(lbf, log(1/110), log(110))
        }), test = as.character(x$Testtype), number = as.integer(x[, 1]))

rm(x, bf, clamp)

# reorder factor levels based on another variable (HPD.mean)
ALL$study.ES_order <- reorder(ALL$study, ALL$HPD.median, mean)

### BF plot
forH1 <- TRUE
fontsize <- 3.2

# reorder factor levels based on BF
ALL$study.BF_order <- reorder(ALL$study, ALL$logBF10, mean)

# reorder factor levels as in data frame
ALL$study.df_order <- factor(ALL$study, levels = rev(ALL$study))

# Define shape: Show an arrow if the BF has been clamped
ALL$shape <- "point"
ALL$shape[ALL$logBF10 > log(110)] <- "rightarrow"
ALL$shape[ALL$logBF10 < -log(110)] <- "leftarrow"

# Define size: < and > must be larger to be visible
ALL$size <- "small"
ALL$size[ALL$logBF10 > log(110)] <- "large"
ALL$size[ALL$logBF10 < -log(110)] <- "large"

p2 <- ggplot(ALL, aes(x = study.BF_order, y = logBF10_clamped)) + geom_point(aes(shape = shape, 
    size = size)) + theme_bw() + geom_hline(yintercept = 0, linetype = "dotted") + ylab("Bayes Factor") + 
    xlab("") + scale_shape_manual(guide = FALSE, values = c(60, 19, 62)) + scale_size_manual(guide = FALSE, 
    breaks = c("small", "large"), values = c(5, 2))

# All the annotation stuff ...
hlines <- c(-log(c(100, 30, 10, 3)), log(c(3, 10, 30, 100)))
p2 <- p2 + geom_hline(yintercept = hlines, linetype = "dotted", color = "darkgrey")
p2 <- p2 + geom_hline(yintercept = log(1), linetype = "dashed", color = "grey20")

p2 <- p2 + annotate("text", x = Inf, y = -5.15, label = paste0("~~Extreme~H[", ifelse(forH1 == 
    TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = -4, label = paste0("~~Very~strong~H[", ifelse(forH1 == 
    TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = -2.85, label = paste0("~~Strong~H[", ifelse(forH1 == 
    TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = -1.7, label = paste0("~~Moderate~H[", ifelse(forH1 == 
    TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = -0.55, label = paste0("~~Anectodal~H[", ifelse(forH1 == 
    TRUE, 0, 1), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = 0.55, label = paste0("~~Anectodal~H[", ifelse(forH1 == 
    TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, vjust = 0.5, size = fontsize, color = "black", 
    parse = TRUE, angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = 5.15, label = paste0("~~Extreme~H[", ifelse(forH1 == 
    TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = 4, label = paste0("~~Very~strong~H[", ifelse(forH1 == 
    TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = 2.86, label = paste0("~~Strong~H[", ifelse(forH1 == 
    TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

p2 <- p2 + annotate("text", x = Inf, y = 1.7, label = paste0("~~Moderate~H[", ifelse(forH1 == 
    TRUE, 1, 0), "]"), hjust = 0, vjust = 0.5, size = fontsize, color = "black", parse = TRUE, 
    angle = 90)

# Add study type to right margin
p2 <- p2 + geom_text(aes(y = Inf, x = study.BF_order, label = test), size = 2, hjust = -0.1)

# set scale ticks
y_breaks <- c(c(-log(c(100, 30, 10, 3)), 0, log(c(3, 10, 30, 100))))
p2 <- p2 + scale_y_continuous(breaks = y_breaks, labels = c("1/100", "1/30", "1/10", 
    "1/3", "1", "3", "10", "30", "100"))

p2 <- p2 + coord_flip()

## Here comes the direty hack:
p2 <- p2 + theme(plot.margin = grid::unit(c(5, 5, 1, 1), "lines"))

# Code to override clipping, from
# http://stackoverflow.com/questions/10014187/displaying-text-below-the-plot-generated-by-ggplot2
gt <- ggplot_gtable(ggplot_build(p2))
gt$layout$clip[gt$layout$name == "panel"] <- "off"

grid::grid.draw(gt)

12.9 Prior and Posterior Distributions with Frills

This plot aims to explain the conclusions that can be drawn from a prior and a posterior distribution (background story: If Bob’s IQ is higher than 70 he will be executed). In a teaching setting it works best when the different elements (A-G) are visually introduced one at a time.

Show R-Code
### prior & posterior parameters
mean.prior <- 75
sd.prior <- 12
mean.posterior <- 73.33644
sd.posterior <- 4.831067

### plot settings
xlim <- c(40, 115)
ylim <- c(0, 0.117)
lwd <- 2
lwd.points <- 2
lwd.axis <- 1.2
cex.points <- 1.4
cex.axis <- 1.2
cex.text <- 1.1
cex.labels <- 1.3
cexLegend <- 1.2

op <- par(mar = c(5.1, 4.1, 4.1, 2.1))

### create empty canvas
plot(1, xlim = xlim, ylim = ylim, axes = FALSE, xlab = "", ylab = "")

### shade prior area < 70
greycol1 <- rgb(0, 0, 0, alpha = 0.2)
greycol2 <- rgb(0, 0, 0, alpha = 0.4)

polPrior <- seq(xlim[1], 70, length.out = 400)
xx <- c(polPrior, polPrior[length(polPrior)], polPrior[1])
yy <- c(dnorm(polPrior, mean.prior, sd.prior), 0, 0)
polygon(xx, yy, col = greycol1, border = NA)

### shade posterior area < 70
polPosterior <- seq(xlim[1], 70, length.out = 400)
xx <- c(polPosterior, polPosterior[length(polPosterior)], polPosterior[1])
yy <- c(dnorm(polPosterior, mean.posterior, sd.posterior), 0, 0)
polygon(xx, yy, col = greycol2, border = NA)

### shade posterior area on interval (81, 84)
polPosterior2 <- seq(81, 84, length.out = 400)
xx <- c(polPosterior2, polPosterior2[length(polPosterior2)], polPosterior2[1])
yy <- c(dnorm(polPosterior2, mean.posterior, sd.posterior), 0, 0)
polygon(xx, yy, col = greycol2, border = NA)

### grey dashed lines to prior mean, posterior mean and posterior at 77
lines(rep(mean.prior, 2), c(0, dnorm(mean.prior, mean.prior, sd.prior)), lty = 2, col = "grey", 
    lwd = lwd)
lines(rep(mean.posterior, 2), c(0, dnorm(mean.posterior, mean.posterior, sd.posterior)), 
    lty = 2, col = "grey", lwd = lwd)
lines(rep(mean.posterior + (mean.posterior - 70), 2), c(0, dnorm(mean.posterior + (mean.posterior - 
    70), mean.posterior, sd.posterior)), lty = 2, col = "grey", lwd = lwd)

### axes
axis(1, at = seq(xlim[1], xlim[2], 5), cex.axis = cex.axis, lwd = lwd.axis)
axis(2, labels = FALSE, tck = 0, lwd = lwd.axis, line = -0.5)

### axes labels
mtext("IQ Bob", side = 1, cex = 1.6, line = 2.4)
mtext("Density", side = 2, cex = 1.5, line = 0)

### plot prior and posterior

# prior
plot(function(x) dnorm(x, mean.prior, sd.prior), xlim = xlim, ylim = ylim, xlab = "", 
    ylab = "", lwd = lwd, lty = 3, add = TRUE)

# posterior
plot(function(x) dnorm(x, mean.posterior, sd.posterior), xlim = xlim, ylim = ylim, add = TRUE, 
    lwd = lwd)

### add points

# posterior density at 70
points(70, dnorm(70, mean.posterior, sd.posterior), pch = 21, bg = "white", cex = cex.points, 
    lwd = lwd.points)

# posterior density at 76.67
points(mean.posterior + (mean.posterior - 70), dnorm(mean.posterior + (mean.posterior - 
    70), mean.posterior, sd.posterior), pch = 21, bg = "white", cex = cex.points, lwd = lwd.points)

# maximum a posteriori value
points(mean.posterior, dnorm(mean.posterior, mean.posterior, sd.posterior), pch = 21, 
    bg = "white", cex = cex.points, lwd = lwd.points)

### credible interval
CIlow <- qnorm(0.025, mean.posterior, sd.posterior)
CIhigh <- qnorm(0.975, mean.posterior, sd.posterior)
yCI <- 0.11

arrows(CIlow, yCI, CIhigh, yCI, angle = 90, code = 3, length = 0.1, lwd = lwd)
text(mean.posterior, yCI + 0.0042, labels = "95%", cex = cex.text)
text(CIlow, yCI, labels = paste(round(CIlow, 2)), cex = cex.text, pos = 2, offset = 0.3)
text(CIhigh, yCI, labels = paste(round(CIhigh, 2)), cex = cex.text, pos = 4, offset = 0.3)

### legend
legendPosition <- 115
legend(legendPosition, ylim[2] + 0.002, legend = c("Posterior", "Prior"), lty = c(1, 
    3), bty = "n", lwd = c(lwd, lwd), cex = cexLegend, xjust = 1, yjust = 1, x.intersp = 0.6, 
    seg.len = 1.2)

### draw labels

# A
arrows(x0 = 57, x1 = 61, y0 = dnorm(62, mean.prior, sd.prior) + 0.0003, y1 = dnorm(62, 
    mean.prior, sd.prior) - 0.007, length = c(0.08, 0.08), lwd = lwd, code = 2)
text(55.94, dnorm(5, mean.prior, sd.prior) + 0.0205, labels = "A", cex = cex.labels)

# B
arrows(x0 = 64.5, x1 = 69, y0 = dnorm(68, mean.posterior, sd.posterior) + 0.003, y1 = dnorm(68, 
    mean.posterior, sd.posterior) - 0.005, length = c(0.08, 0.08), lwd = lwd, code = 2)
text(63.5, dnorm(68, mean.posterior, sd.posterior) + 0.0042, labels = "B", cex = cex.labels)

# C
arrows(x0 = mean.posterior + 1, x1 = mean.posterior + 6, y0 = dnorm(mean.posterior, mean.posterior, 
    sd.posterior) + 0.001, y1 = dnorm(mean.posterior, mean.posterior, sd.posterior) + 
    0.008, length = c(0.08, 0.08), lwd = lwd, code = 1)
text(mean.posterior + 7, dnorm(mean.posterior, mean.posterior, sd.posterior) + 0.0093, 
    labels = "C", cex = cex.labels)

# D
arrows(x0 = 70 - 0.25, x1 = 70 - 0.25, y0 = dnorm(70, mean.posterior, sd.posterior) + 
    0.005, y1 = 0.092, length = c(0.08, 0.08), lwd = lwd, code = 1)
lines(c(70 - 0.25, mean.posterior), rep(0.092, 2), lwd = lwd)
arrows(x0 = mean.posterior, x1 = mean.posterior, y0 = 0.092, y1 = dnorm(mean.posterior, 
    mean.posterior, sd.posterior) + 0.003, length = c(0.08, 0.08), lwd = lwd, code = 2)
ratio <- dnorm(mean.posterior, mean.posterior, sd.posterior)/dnorm(70, mean.posterior, 
    sd.posterior)
text(mean(c(70 - 0.255, mean.posterior)), 0.096, labels = paste(round(ratio, 2), "x"), 
    cex = cex.text)
text(70 - 1.5, dnorm(70, mean.posterior, sd.posterior) + 0.02, labels = "D", cex = cex.labels)

# E
arrows(x0 = 70 + 1, x1 = mean.posterior + (mean.posterior - 70) - 1, y0 = dnorm(70, mean.posterior, 
    sd.posterior), y1 = dnorm(mean.posterior + (mean.posterior - 70), mean.posterior, 
    sd.posterior), length = c(0.08, 0.08), lwd = lwd, code = 3)
text(74.9, dnorm(mean.posterior + (mean.posterior - 70), mean.posterior, sd.posterior) - 
    0.005, labels = "E", cex = cex.labels)

# F
arrows(x0 = 82.5, x1 = 87, y0 = dnorm(82, mean.posterior, sd.posterior) - 0.012, y1 = dnorm(82, 
    mean.posterior, sd.posterior) - 0.005, length = c(0.08, 0.08), lwd = lwd, code = 1)
text(88, dnorm(82, mean.posterior, sd.posterior) - 0.0034, labels = "F", cex = cex.labels)

# G
arrows(x0 = CIhigh + 6, x1 = CIhigh + 8.2, y0 = yCI, y1 = yCI, length = c(0.08, 0.08), 
    lwd = lwd, code = 1)
text(CIhigh + 9.5, yCI, labels = "G", cex = cex.labels)

### additional information
scores <- "Bob's IQ scores: {73, 67, 79}"
priorText1 <- "Prior distribution:"
priorText2 <- expression(paste("IQ Bob ~ N(", 75, ", ", 12^2, ")"))
posteriorText1 <- "Posterior distribution:"
posteriorText2 <- expression(paste("IQ Bob ~ N(", 73.34, ", ", 4.83^2, ")"))

xx <- 87
yCI2 <- 0.12

text(xx, yCI2 - 0.033, labels = priorText1, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.042, labels = priorText2, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.059, labels = scores, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.074, labels = posteriorText1, cex = cexLegend, pos = 4, offset = 0.3)
text(xx, yCI2 - 0.083, labels = posteriorText2, cex = cexLegend, pos = 4, offset = 0.3)

par(op)

12.10 Heatmap Updating

The top row shows a sequence of heatmaps that describe a joint distribution; the bottom row shows the associated predictions. After every observation (the red cross), the heatmap is updated. As information flows in, from left to right, the heatmap becomes more concentrated and the predictions become more specific.

Show R-Code
### joint prior density function
djointprior <- function(BobsTrueIQ, TestSD) {
    
    dnorm(BobsTrueIQ, mean = 75, sd = 12) * 1/10  # 1/10 because TestSD \in (5,15)
}

### function that plots the joint prior
heatmap.prior <- function() {
    
    op <- par(mar = c(5.1, 5.1, 5.1, 3.1))
    
    BobsTrueIQ <- seq(40, 110, length.out = 151)
    TestSD <- seq(5, 15, length.out = 151)
    density <- outer(BobsTrueIQ, TestSD, djointprior)
    
    image(x = BobsTrueIQ, y = TestSD, z = density, col = topo.colors(50), xlab = "", 
        ylab = "", axes = FALSE)
    
    axis(1, at = seq(40, 110, 10), las = 1, cex.axis = 1.6)
    axis(2, at = seq(5, 15, 2), las = 1, cex.axis = 1.6)
    
    mtext("IQ Bob", 1, cex = 1.4, line = 2.75)
    mtext("Test SD", 2, cex = 1.4, line = 2.8)
    
    par(op)
}

### function that plots the joint posterior
library(ks)
heatmap.posterior <- function(samples) {
    
    op <- par(mar = c(5.1, 5.1, 5.1, 3.1))
    
    BobsTrueIQ <- samples$BUGSoutput$sims.list$BobsTrueIQ
    TestSD <- samples$BUGSoutput$sims.list$TestSD
    
    d <- kde(cbind(BobsTrueIQ, TestSD), xmin = c(40, 5), xmax = c(110, 15))
    
    image(x = d$eval.points[[1]], y = d$eval.points[[2]], z = d$estimate, col = topo.colors(50), 
        xlab = "", ylab = "", axes = FALSE)
    
    axis(1, at = seq(40, 110, 10), las = 1, cex.axis = 1.6)
    axis(2, at = seq(5, 15, 2), las = 1, cex.axis = 1.6)
    
    mtext("IQ Bob", 1, cex = 1.4, line = 2.75)
    mtext("Test SD", 2, cex = 1.4, line = 2.8)
    
    par(op)
}

### function that plots the predictive data distribution
plot.predictive <- function(samples, prior = FALSE, xlim = c(15, 135), ylim = c(0, 0.36), 
    lwd = 2, lwd.axis = 1, cex.axis = 1.6) {
    
    if (prior) {
        
        pred <- samples$BUGSoutput$sims.list$BobsIQScoresPriorPred
        
    } else {
        
        pred <- samples$BUGSoutput$sims.list$BobsIQScoresPostPred
        
    }
    
    mean.pred <- mean(pred)
    sd.pred <- sd(pred)
    
    ### plot settings
    op <- par(mar = c(5.1, 5.1, 5.1, 3.1))
    
    ### create empty canvas
    plot(1, xlim = xlim, ylim = ylim, axes = FALSE, xlab = "", ylab = "")
    
    plot(function(x) dnorm(x, mean.pred, sd.pred), xlim = xlim, ylim = ylim, xlab = "", 
        ylab = "", lwd = lwd, add = TRUE)
    
    ### axes
    axis(1, at = seq(15, 135, 20), cex.axis = cex.axis, lwd = lwd.axis)
    axis(2, at = ylim, labels = FALSE, tck = 0, lwd = lwd.axis)
    
    ### axes labels
    mtext("Predicted IQ Scores", side = 1, cex = 1.4, line = 2.75)
    mtext("Density", side = 2, cex = 1.4, line = 0.8)
    
    par(op)
    
}

########################## 8-panel plot ##

### load samples

load(file = "samplesBob1.Rdata")
load(file = "samplesBob2.Rdata")
load(file = "samplesBob3.Rdata")

### plot

op <- par(mfrow = c(2, 4), xpd = NA)

heatmap.prior()
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
arrows(x0 = 95, x1 = 125, y0 = -1, y1 = 2, length = c(0.2, 0.2), lwd = 3, code = 2)

heatmap.posterior(samplesBob1)
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
arrows(x0 = 95, x1 = 125, y0 = -1, y1 = 2, length = c(0.2, 0.2), lwd = 3, code = 2)

heatmap.posterior(samplesBob2)
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)
arrows(x0 = 95, x1 = 125, y0 = -1, y1 = 2, length = c(0.2, 0.2), lwd = 3, code = 2)

heatmap.posterior(samplesBob3)
arrows(x0 = 75, x1 = 75, y0 = 2, y1 = -1, length = c(0.2, 0.2), lwd = 3, code = 2)

plot.predictive(samplesBob1, prior = TRUE, ylim = c(0, 0.027))
points(73, 0.0005, col = "darkred", pch = 4, cex = 1.6, lwd = 3)

plot.predictive(samplesBob1, ylim = c(0, 0.034))
points(73, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(67, 0.0005, col = "darkred", pch = 4, cex = 1.6, lwd = 3)

plot.predictive(samplesBob2, ylim = c(0, 0.038))
points(73, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(67, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(79, 0.0005, col = "darkred", pch = 4, cex = 1.6, lwd = 3)

plot.predictive(samplesBob3, ylim = c(0, 0.041))
points(73, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(67, 0.0005, pch = 4, cex = 1.6, lwd = 3)
points(79, 0.0005, pch = 4, cex = 1.6, lwd = 3)

par(op)

12.11 Meta-Analytic Forest Plot

This graph contains a lot of information: study number, raw summary data, mean effect size, 95% confidence intervals, and a meta-analytic estimate. Importantly, the broad picture can be obtained from a brief look at the intervals, whereas the numbers allow a more detailed analysis.

Show R-Code
load("metaG.Rdata")

g <- c(-0.35, -0.67, -0.25, -0.22, -0.22, -0.36, -0.67, -0.25, -0.22, -0.22, -0.36, -0.22, 
    -0.67, -0.25, -0.22, -0.36, -0.67, -0.25, -0.22, -0.22, -0.36)

gSE <- c(0.469041575982343, 0.469041575982343, 0.458257569495584, 0.458257569495584, 
    0.458257569495584, 0.458257569495584, 0.469041575982343, 0.458257569495584, 0.458257569495584, 
    0.458257569495584, 0.458257569495584, 0.458257569495584, 0.469041575982343, 0.458257569495584, 
    0.458257569495584, 0.458257569495584, 0.469041575982343, 0.458257569495584, 0.458257569495584, 
    0.458257569495584, 0.458257569495584)

cMeanSmile <- c("3.48", "3.75", "3.48", "3.67", "3.60", "3.58", "3.75", "3.48", "3.67", 
    "3.60", "3.58", "3.67", "3.75", "3.48", "3.60", "3.58", "3.75", "3.48", "3.67", "3.60", 
    "3.58")

cMeanPout <- c("3.96", "4.81", "3.81", "3.94", "3.88", "4.03", "4.81", "3.81", "3.94", 
    "3.88", "4.03", "3.94", "4.81", "3.81", "3.88", "4.03", "4.81", "3.81", "3.94", "3.88", 
    "4.03")

forest(x = g, sei = gSE, xlab = "Hedges' g", cex.lab = 1.4, ilab = cbind(cMeanSmile, 
    cMeanPout), ilab.xpos = c(-3.2, -2.5), cex.axis = 1.1, mlab = "Meta-Analytic Effect:", 
    lwd = 1.4, rows = 22:2, addfit = FALSE, atransf = FALSE, ylim = c(-2, 25))

text(-4.05, 24, "Study", cex = 1.3)
text(-3.2, 24, "Smile", cex = 1.3)
text(-2.5, 24, "Pout", cex = 1.3)
text(2.75, 24, "Hedges' g [95% CI]", cex = 1.3)

abline(h = 1, lwd = 1.4)
addpoly(metaG, atransf = FALSE, row = -1, cex = 1.3, mlab = "Meta-Analytic Effect Size:")

12.12 Many Bayes Factors with Zoom

This two-panel plot presents replication Bayes factors (Verhagen & Wagenmakers, 2014) for the experiments in the “pipeline project” (Schweinsberg et al., in press). The problem that this graph seeks to overcome is that some Bayes factors are very large, extending the scale on the x-axis and making it impossible to discern what happens in the interesting region where the evidence is less compelling. Therefore, the bottom panel zooms in on the area of interest. This fact is evident from the grey area that spreads out from the top panel to the lower panel.

Show R-Code
############################### @ plot replication BFs @##

load("logRepBFs.Rdata")
load("scaleBF.Rdata")
load("scaleBF2.Rdata")
load("indices.Rdata")

studies <- c("MoralInversion", "BadTipper", "BeliefInconsistency", "MoralCliff", "ColdHearted", "BurnInHell", "Biggot", "PresumptionOfGuilt", "intuitiveEconomics", 
    "HigherCompany", "higherCharity")

op <- par(mar = c(4, 26, 1, 4), mfrow = c(2, 1))

plot(1, xlim = scaleBF$lim, ylim = c(0, 12), type = "n", axes = FALSE, xlab = "", ylab = "")

lines(rep(0, 2), c(0.5, 11), lty = 2, lwd = 2)
greycol <- rgb(0, 0, 0, alpha = 0.2)
rect(xleft = log(1/100), ybottom = 0.5, xright = log(100), ytop = 11, lwd = 2, col = greycol, border = NA)

y <- 11
for (study in studies) {
    
    points(logRepBFs[[study]], rep(y, length(logRepBFs[[study]])), pch = 21, bg = "grey", cex = 1.5, lwd = 1.3)
    y <- y - 1
    
}

axis(1, at = scaleBF$at, labels = scaleBF$lab, cex.axis = 1.4, lwd = 1.4, line = -1.5)
axis(2, at = 1:11, labels = NA, las = 1, cex.axis = 1.4, lwd = 1.4)
axis(2, at = 11, labels = expression(paste("Moral Inversion ", (BF[1][0] == 7.526))), las = 1, cex.axis = 1.4)
axis(2, at = 10, labels = expression(paste("Bad Tipper ", (BF[1][0] == 5.525))), las = 1, cex.axis = 1.4)
axis(2, at = 9, labels = expression(paste("Belief-Act Inconsistency ", (BF[1][0] == 1.119))), las = 1, cex.axis = 1.4)
axis(2, at = 8, labels = expression(paste("Moral Cliff ", (BF[1][0] == 3.084 %*% 10^7))), las = 1, cex.axis = 1.4)
axis(2, at = 7, labels = expression(paste("Cold Hearted Prosociality ", (BF[1][0] == 4.155 %*% 10^24))), las = 1, cex.axis = 1.4)
axis(2, at = 6, labels = expression(paste("Burn in Hell ", (BF[1][0] == 3.031))), las = 1, cex.axis = 1.4)
axis(2, at = 5, labels = expression(paste("Bigot-Misanthrope ", (BF[1][0] == 61465))), las = 1, cex.axis = 1.4)
axis(2, at = 4, labels = expression(paste("Presumption of Guilt ", (BF[0][1] == 5.604))), las = 1, cex.axis = 1.4)
axis(2, at = 3, labels = expression(paste("Intuitive Economics ", (BF[1][0] == 7.454 %*% 10^6))), las = 1, cex.axis = 1.4)
axis(2, at = 2, labels = expression(paste("Higher Standards-Company ", (BF[0][1] == 1.781))), las = 1, cex.axis = 1.4)
axis(2, at = 1, labels = expression(paste("Higher Standards-Charity ", (BF[1][0] == 131.7))), las = 1, cex.axis = 1.4)

mtext(expression(BF["r"]["0"]), side = 1, line = 1.6, cex = 1.7)


## zoom-in ##

plot(1, xlim = scaleBF2$lim, ylim = c(0, 12), type = "n", axes = FALSE, xlab = "", ylab = "")

rect(xleft = log(1/100), ybottom = 0.5, xright = log(100), ytop = 11.2, lwd = 2, col = greycol, border = greycol, density = NA)

y <- 11
lines(rep(0, 2), c(0.5, 11), lty = 2, lwd = 2)

for (study in studies) {
    
    points(logRepBFs[[study]][indices[[study]]], rep(y, length(logRepBFs[[study]][indices[[study]]])), pch = 21, bg = "grey", cex = 1.5, lwd = 1.3)
    y <- y - 1
    
}

axis(1, at = scaleBF2$at, labels = scaleBF2$lab, cex.axis = 1.4, lwd = 1.2, line = -1.5)
axis(2, at = 1:11, labels = NA, las = 1, cex.axis = 1.4, lwd = 1.4)
axis(2, at = 11, labels = expression(paste("Moral Inversion ", (BF[1][0] == 7.526))), las = 1, cex.axis = 1.4)
axis(2, at = 10, labels = expression(paste("Bad Tipper ", (BF[1][0] == 5.525))), las = 1, cex.axis = 1.4)
axis(2, at = 9, labels = expression(paste("Belief-Act Inconsistency ", (BF[1][0] == 1.119))), las = 1, cex.axis = 1.4)
axis(2, at = 8, labels = expression(paste("Moral Cliff ", (BF[1][0] == 3.084 %*% 10^7))), las = 1, cex.axis = 1.4)
axis(2, at = 7, labels = expression(paste("Cold Hearted Prosociality ", (BF[1][0] == 4.155 %*% 10^24))), las = 1, cex.axis = 1.4)
axis(2, at = 6, labels = expression(paste("Burn in Hell ", (BF[1][0] == 3.031))), las = 1, cex.axis = 1.4)
axis(2, at = 5, labels = expression(paste("Bigot-Misanthrope ", (BF[1][0] == 61465))), las = 1, cex.axis = 1.4)
axis(2, at = 4, labels = expression(paste("Presumption of Guilt ", (BF[0][1] == 5.604))), las = 1, cex.axis = 1.4)
axis(2, at = 3, labels = expression(paste("Intuitive Economics ", (BF[1][0] == 7.454 %*% 10^6))), las = 1, cex.axis = 1.4)
axis(2, at = 2, labels = expression(paste("Higher Standards-Company ", (BF[0][1] == 1.781))), las = 1, cex.axis = 1.4)
axis(2, at = 1, labels = expression(paste("Higher Standards-Charity ", (BF[1][0] == 131.7))), las = 1, cex.axis = 1.4)

mtext(expression(BF["r"]["0"]), side = 1, line = 1.6, cex = 1.7)


par(xpd = NA)

polygon(x = c(log(1/100), log(1/42.5), log(1/38.5), log(100), log(1/100)), y = c(11.2, 15.63, 15.63, 11.2, 11.2), col = greycol, border = NA)

par(op)

12.13 Reproducibility Project: The Correlation Graph

Courtesy of Fred Hasselman, this graph is a slightly edited version of the one that was prominently displayed in a groundbreaking publication (Open Science Collaboration, 2015). The associated information on the Open Science Framework is here. You may compare versions – what has changed?

Show R-Code
# SETUP local R-------------------------------------------------------------------
library(grid)

# Use this code (from the devtools package) to source C-3PR directly from GitHub:
library(devtools)
source_url('https://raw.githubusercontent.com/FredHasselman/toolboxR/master/C-3PR.R')

# This will load and (if necessary) install libraries frequently used for data management and plotting
in.IT(c('ggplot2','RColorBrewer','lattice','gridExtra','plyr','dplyr','httr'))


RPPdata<-read.csv('rpp_data.csv',stringsAsFactors=F )
RPPdata<-df.Clean(RPPdata)
RPPdata<-RPPdata$df

# Select the completed replication studies
RPPdata <- dplyr::filter(RPPdata, !is.na(T.pval.USE.O),!is.na(T.pval.USE.R))
# We have 99 studies for which p-values and effect sizes could be calculated
nrow(RPPdata)
# We have 97 studies for which p-values of the original effect were significantly below .05
idOK <- complete.cases(RPPdata$T.r.O,RPPdata$T.r.R)
# sum(idOK)

# Get ggplot2 themes predefined in C-3PR
mytheme <- gg.theme("clean")

# Get the Replication observed power
RPPdata$Power.Rn <- as.numeric(RPPdata$Power.R)

########################
# FIGURE 3
# EFFECT SIZE DENSITY PLOTS -------------------------------------------------------------
########################

# Setup some variables
RPPdata$oriSig <- "Not Significant"
# 3 studies claimed an effect at .05 < p < .06
RPPdata$oriSig[RPPdata$T.pval.USE.O<=.06] <- "Significant"
RPPdata$oriSig <- factor(RPPdata$oriSig)

RPPdata$repSig <- "Not Significant"
RPPdata$repSig[RPPdata$T.pval.USE.R<=.05] <- "Significant"
RPPdata$repSig <- factor(RPPdata$repSig)
RPPdata$repSig <- factor(RPPdata$repSig)

# Create a scatterplot with density margin plots

# The plotHolder() function from C-3PR creates a blank plot template that will hold the figures
blankPlot <- plotHolder()

# X margin density plot (note: gg.theme() from C-3PR can be used directly in a ggplot2() call)
xDense <- ggplot(RPPdata, aes(x=T.r.O, fill=oriSig)) + 
  geom_density(aes(y= ..count..),trim=F,alpha=.5) + 
  xlab("") + ylab("") + xlim(0,1) +
  gg.theme("noax") + 
  theme(legend.position = "none",plot.margin = unit(c(0,0,0,4), "lines"))

## Uncomment to save subplot
# ggsave("RPP_F3_xDense.png",plot=xDense)

# Y margin density plot (note: gg.theme() from C-3PR can be used directly in a ggplot2() call)
yDense <- ggplot(RPPdata, aes(x=T.r.R, fill=repSig)) + 
  geom_density(aes(y= ..count..),trim=F,alpha=.5) + 
  xlab("") + ylab("") + xlim(-.5,1) + 
  coord_flip() + 
  gg.theme("noax") + 
  theme(legend.position = "none", plot.margin = unit(c(0,0,3,0), "lines")) 

## Uncomment to save subplot
# ggsave("RPP_F3_yDense.png",plot=yDense)

# The main scatterplot (note: gg.theme() from C-3PR can be used directly in a ggplot2() call)
scatterP<-
  ggplot(RPPdata,aes(x=T.r.O,y=T.r.R)) +  
  geom_hline(aes(yintercept=0),linetype=2) +
  geom_abline(intercept=0,slope=1,color="Grey60")+
  geom_point(aes(size=Power.Rn,fill=repSig),color="Grey30",shape=21,alpha=.8) + 
  geom_rug(aes(color=oriSig),size=1,sides="b",alpha=.6) + 
  geom_rug(aes(color=repSig),,size=1,sides="l",alpha=.6) + 
  scale_x_continuous(name="Original Effect Size",limits=c(0,1),breaks=c(0,.25,.5,.75,1)) + 
  scale_y_continuous(name="Replication Effect Size",limits=c(-.5,1),breaks=c(-.5,-.25,0,.25,.5,.75,1)) + 
  ggtitle("") + xlab("") + ylab("") + 
  scale_size_continuous(name="Replication Power",range=c(2,9)) + 
  scale_color_discrete(name="p-value") +
  scale_fill_discrete(name="p-value") +
  gg.theme("clean") + 
  theme(legend.position=c(.87,.185), legend.text=element_text(size=16), legend.title=element_text(size=18), plot.margin = unit(c(-2,-1.5,2,2), "lines"), axis.text.x=element_text(size=20),  axis.text.y=element_text(size=20), axis.title.x=element_text(size=25, vjust=-1.6), axis.title.y=element_text(size=26, vjust=2.6)) 

## Uncomment to save subplot
# ggsave("RPP_F3_scatter.png",plot=scatterP)

# Yet another way to organise plots: grid.arrange() from the gridExtra package.
grid.arrange(xDense, blankPlot, scatterP, yDense, ncol=2, nrow=2, widths=c(4, 1.4), heights=c(1.4, 4))

12.14 Reproducibility Project: The Layered-Violin Graph

Courtesy of Fred Hasselman, this is a slightly edited version of a plot for the Reproducibility Project. The graph shows violin plots for p-values (left panel) and effect-sizes (right panel). Note that the violin plot is divided into four areas.

Show R-Code
######################################################################################
#                          RPP Manuscript Figure 1 (ViolinQtilePlots)                #
#                                                                                    #
# Created by [Fred Hasselman](https://osf.io/ujgs6/)  on behalf of the RPP intiative #
######################################################################################

# FUNCTIONS ---------------------------------------------------------------

## GET DATA

 df.Clean <- function(df,Sep="."){
  nms   <- colnames(df)
  rws   <- rownames(df)

  # Change punctuation and blankss in variable names to points
  nmsP  <- gsub("([[:punct:]]|[[:blank:]])+","+",nms)
  nmsPP <- gsub("(^[+]|[+]$)+","",nmsP)
  nmsPP <- gsub("[+]",Sep,nmsPP)
  # Check for double names
  ifelse(length(unique(nmsPP))==length(nmsPP),{nms <- nmsPP},{
    id2 <- which(plyr::laply(nmsPP,function(n) sum(nmsPP%in%n))>1)
    nms <- nmsPP
    nms[id2] <- paste(nmsPP[id2],id2,sep=".")})

  colnames(df) <- nms
  df      <- dplyr::select(df,which(nms%in%nms[nms!=""]))
  df[ ,1] <- paste0("Row.",seq(1,nrow(df)))
  colnames(df)[1] <- paste("Local","ID",sep=Sep)
  return(list(df=df,
              nms=nms,
              rws=rws))
}

get.OSFfile <- function(# Function to download OSF file modified from code by Sacha Epskamp
  code,  #Either "https://osf.io/XXXXX/" or just the code
  dir = tempdir(), # Output location
  scanMethod, #  "readLines" or "RCurl". Leave missing to automatically chose
  downloadMethod = c("httr","downloader","curl"), # First one is chosen
  dataFrame = TRUE,
  sep = ',',
  dfCln = FALSE
){
  # Check if input is code:
  if (!grepl("osf\\.io",code)){
    URL <- sprintf("https://osf.io/%s/",code)
  } else URL <- code

  # Scan page:
  if (grepl("Windows",Sys.info()[['sysname']],ignore.case=TRUE)){
    try(setInternet2(TRUE))
  }

  if (missing(scanMethod)){
    scanMethod <- ifelse(grepl("Windows",Sys.info()[['sysname']],ignore.case=TRUE), "readLines", "RCurl")
  }
  if (scanMethod == "readLines"){
    Page <- paste(readLines(URL),collapse="\n")
  } else if (scanMethod == "RCurl"){
    library("RCurl")
    Page <- RCurl::getURL(URL)
  } else if (scanMethod == "httr"){
    Page <- httr::GET(URL)
    Page <- paste(Page,collapse="\n")
  } else stop("Invalid scanMethod")


  # Create download link:
  URL <- gsub("/$","",URL)
  #   Link <- paste0(URL,"/?action=download&version=1")
  Link <- paste0(URL,"/?action=download")

  # Extract file name:
  FileName <- regmatches(Page,gregexpr("(?<=\\OSF \\| ).*?(?=\\)", Page, perl=TRUE))[[1]]
  FullPath <- paste0(dir,"/",FileName)

  info <- NULL
  # Download file:
  if (downloadMethod[[1]]=="httr"){
    library("httr")
    info <- httr::GET(Link, httr::write_disk(FullPath, overwrite = TRUE))
  } else if (downloadMethod[[1]]=="downloader"){
    library("downloader")
    downloader:::download(Link, destfile = FullPath, quiet=TRUE)
  } else if (downloadMethod[[1]]=="curl"){
    system(sprintf("curl -J -L %s > %s", Link, FullPath), ignore.stderr = TRUE)
  }  else stop("invalid downloadMethod")

  df <- NULL
  if(dataFrame==TRUE){
    if(grepl('xls',FileName)){
      df <- tbl_df(read.xlsx2(file=FullPath,sheetIndex=1))
    } else {
      df <- tbl_df(read.table(FullPath,stringsAsFactors=F,fill = T,header=T,sep=sep, comment.char = "",quote = "\""))
    }
    if(dfCln==TRUE){df <- df.Clean(df)} else {df$df <- df}

    return(list(df   = df$df,
                info = list(FilePath=FullPath,
                            Info=info,
                            ori.Colnames=tbl_df(data.frame(ori.colnames=df$nms)),
                            ori.Rownames=tbl_df(data.frame(ori.rownames=df$rws))
                )))
  } else {
    # Return location of file:
    return(FilePath=FullPath)
  }
}


## PLOTS

gg.theme <- function(type=c("clean","noax")[1],useArial = F, afmPATH="~/Dropbox"){
  require(ggplot2)
  if(useArial){
    set.Arial(afmPATH)
    bf_font="Arial"
  } else {bf_font="Helvetica"}

  switch(type,
         clean = theme_bw(base_size = 16, base_family=bf_font) +
           theme(axis.text.x     = element_text(size = 14),
                 axis.title.y    = element_text(vjust = +1.5),
                 panel.grid.major  = element_blank(),
                 panel.grid.minor  = element_blank(),
                 legend.background = element_blank(),
                 legend.key = element_blank(),
                 panel.border = element_blank(),
                 panel.background = element_blank(),
                 axis.line  = element_line(colour = "black")),

         noax = theme(line = element_blank(),
                      text  = element_blank(),
                      title = element_blank(),
                      plot.background = element_blank(),
                      panel.border = element_blank(),
                      panel.background = element_blank())
  )
}

set.Arial <- function(afmPATH="~/Dropbox"){
  # Set up PDF device on MAC OSX to use Arial as a font in Graphs
  if(nchar(afmPATH>0)){
    if(file.exists(paste0(afmPATH,"/Arial.afm"))){
      Arial <- Type1Font("Arial",
                         c(paste(afmPATH,"/Arial.afm",sep=""),
                           paste(afmPATH,"/Arial Bold.afm",sep=""),
                           paste(afmPATH,"/Arial Italic.afm",sep=""),
                           paste(afmPATH,"/Arial Bold Italic.afm",sep="")))
      if(!"Arial" %in% names(pdfFonts())){pdfFonts(Arial=Arial)}
      if(!"Arial" %in% names(postscriptFonts())){postscriptFonts(Arial=Arial)}
      return()
    } else {disp(header='useArial=TRUE',message='The directory did not contain the *.afm version of the Arial font family')}
  } else {disp(header='useArial=TRUE',message='Please provide the path to the *.afm version of the Arial font family')}
}

#function to create geom_ploygon calls
fill_viol<-function(gr.df,gr,qtile,probs){
  # SETUP VIOLIN QUANTILE PLOTS -----------------------------------
  # This is adapted from: http://stackoverflow.com/questions/22278951/combining-violin-plot-with-box-plot

  ifelse(is.null(qtile),{
    cuts <- cut(gr.df$y, breaks = quantile(gr.df$y, probs, na.rm=T, type=3, include.lowest = T, right = T), na.rm=T)},{
      cuts <- cut(gr.df$y, breaks = qtile, na.rm=T)
    }
  )
  quants <- mutate(gr.df,
                   x.l=x-violinwidth/2,
                   x.r=x+violinwidth/2,
                   cuts=cuts)

  plotquants <- data.frame(x=c(quants$x.l,rev(quants$x.r)),
                           y=c(quants$y,rev(quants$y)),
                           id=c(quants$cuts,rev(quants$cuts)))

  #cut by quantile to create polygon id
  geom <- geom_polygon(aes(x=x,y=y,fill=factor(id)),data=plotquants,alpha=1)

  return(list(quants=quants,plotquants=plotquants,geom=geom))
}

vioQtile <- function(gg=NULL,qtiles=NULL,probs=seq(0,1,.25),labels=paste(probs[-1]*100),withData=FALSE){
  require(ggplot2)
  # SETUP VIOLIN QUANTILE PLOTS -----------------------------------
  # This is adapted from: http://stackoverflow.com/questions/22278951/combining-violin-plot-with-box-plot
  #
  # Changed:
  # - Deal with 'empty' quantile groups
  # - Deal with original data
  # - More input, more output
  g.df <- ggplot_build(gg)$data[[1]]    # use ggbuild to get the outline co-ords

  ifelse(is.null(qtiles),{
    gg <- gg + lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x, ],x,NULL,probs)$geom)},{
    gg <- gg + lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x, ],x,qtiles[x, ],probs)$geom)}
  )

  gg <- gg + geom_hline(aes(yintercept=0)) +
    scale_fill_grey(name="Quantile\n",labels=labels,guide=guide_legend(reverse=T,label.position="right")) +
    stat_summary(fun.y=median, geom="point", size=8, color="grey80",shape=21,fill="white")

  if(withData){
    ifelse(is.null(qtiles),{
      ggData <- lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x,],x,NULL,probs))},{
        ggData <- lapply(unique(g.df$group), function(x) fill_viol(g.df[g.df$group==x,],x,qtiles[x,],probs))
      }
    )
    return(list(ggGraph=gg,ggData=ggData))
  } else {
    return(gg)
  }
}

# MULTIPLOT FUNCTION ------------------------------------------------------------------------------------------------------------------
#
# [copied from http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/ ]
#
# ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects)
# - cols:   Number of columns in layout
# - layout: A matrix specifying the layout. If present, 'cols' is ignored.
#
# If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE),
# then plot 1 will go in the upper left, 2 will go in the upper right, and
# 3 will go all the way across the bottom.
#
multi.PLOT <- function(..., plotlist=NULL, file, cols=1, layout=NULL) {
  require(grid)

  # Make a list from the ... arguments and plotlist
  plots <- c(list(...), plotlist)

  numPlots = length(plots)

  # If layout is NULL, then use 'cols' to determine layout
  if (is.null(layout)) {
    # Make the panel
    # ncol: Number of columns of plots
    # nrow: Number of rows needed, calculated from # of cols
    layout <- matrix(seq(1, cols * ceiling(numPlots/cols)),
                     ncol = cols, nrow = ceiling(numPlots/cols))
  }

  if (numPlots==1) {
    print(plots[[1]])

  } else {
    # Set up the page
    grid.newpage()
    pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))

    # Make each plot, in the correct location
    for (i in 1:numPlots) {
      # Get the i,j matrix positions of the regions that contain this subplot
      matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))

      print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row,
                                      layout.pos.col = matchidx$col))
    }
  }
}


# MAIN CODE ---------------------------------------------------------------

# SETUP local R-------------------------------------------------------------------
require('ggplot2')
require('RColorBrewer')
require('lattice')
require('gridExtra')
require('plyr')
require('dplyr')
require('httr')
require('RCurl')

# Read the data from the OSF storage
# Note: get.OSFfile() returns a list with the .csv data (df) and information (info) containing the URL download timestamp and original column and rownames (these names will be changed if dfCln=TRUE).
RPPdata <- get.OSFfile(code='https://osf.io/fgjvw/',dfCln=T)$df

## If you dowloaded the csv file to your harddrive use this code:
#  RPPdata<-read.csv('rpp_data.csv',stringsAsFactors=F )
#  RPPdata<-df.Clean(RPPdata)
#  RPPdata<-RPPdata$df

# Select the completed replication studies
RPPdata <- dplyr::filter(RPPdata, !is.na(T.pval.USE.O),!is.na(T.pval.USE.R))
# We have 99 studies for which p-values and effect sizes could be calculated
nrow(RPPdata)
# We have 97 studies for which p-values of the original effect were significantly below .05
idOK <- complete.cases(RPPdata$T.r.O,RPPdata$T.r.R)
sum(idOK)

# Get ggplot2 themes predefined in C-3PR
mytheme <- gg.theme("clean")

############
# FIGURE 1
# VIOLIN QUANTILE PLOTS (VQP) -----------------------------------------------
############

# Restructure the data to "long" format: Study type will be a factor
df <- dplyr::select(RPPdata,starts_with("T."))
df <- data.frame(EffectSize=as.numeric(c(df$T.r.O,df$T.r.R)),p.value=as.numeric(c(df$T.pval.USE.O,df$T.pval.USE.R)),grp=factor(c(rep("Original Studies",times=length(df$T.r.O)),rep("Replications",times=length(df$T.r.R)))))

# Create some variables for plotting
df$grpN <- as.numeric(df$grp)
probs   <- seq(0,1,.25)

# VQP PANEL A: p-value -------------------------------------------------

# Get p-value quantiles and frequencies from data
qtiles <- ldply(unique(df$grpN),function(gr) quantile(round(df$p.value[df$grpN==gr],digits=4),probs,na.rm=T,type=3))
freqs  <- ldply(unique(df$grpN),function(gr) table(cut(df$p.value[df$grpN==gr],breaks=qtiles[gr,],na.rm=T,include.lowest=T,right=T)))
labels <- sapply(unique(df$grpN),function(gr)levels(cut(round(df$p.value[df$grpN==gr],digits=4), breaks = qtiles[gr,],na.rm=T,include.lowest=T,right=T)))

# Get regular violinplot using package ggplot2
g.pv <- ggplot(df,aes(x=grp,y=p.value)) + geom_violin(aes(group=grp),scale="width",color="grey30",fill="grey30",trim=T,adjust=.7)
# Cut at quantiles using vioQtile() in C-3PR
g.pv0 <- vioQtile(g.pv,qtiles,probs)
# Garnish
g.pv1 <- g.pv0 + geom_hline(aes(yintercept=.05),linetype=2) +
  ggtitle("A") + xlab("") + ylab("p-value") +
  mytheme + theme(legend.position=c(.5,.5), legend.text=element_text(size=20), legend.title=element_text(size=22), axis.text.x=element_text(size=26),  axis.text.y=element_text(size=22), axis.title.y=element_text(size=30, vjust=2.6), title=element_text(size=27)) 
# View
g.pv1

## Uncomment to save panel A as a seperate file
# ggsave("RPP_F1_VQPpv.eps",plot=g.pv1)

# VQP PANEL B: effect size -------------------------------------------------

# Get effect size quantiles and frequencies from data
qtiles <- ldply(unique(df$grpN),function(gr) quantile(df$EffectSize[df$grpN==gr],probs,na.rm=T,type=3,include.lowest=T))
freqs  <- ldply(unique(df$grpN),function(gr) table(cut(df$EffectSize[df$grpN==gr],breaks=qtiles[gr,],na.rm=T,include.lowest=T)))
labels <- sapply(unique(df$grpN),function(gr)levels(cut(round(df$EffectSize[df$grpN==gr],digits=4), breaks = qtiles[gr,],na.rm=T,include.lowest=T,right=T)))

# Check the Quantile bins!
ori           <-cbind(freq=as.numeric(t(freqs[1,])))
rownames(ori) <- labels[,1]
ori

rep           <-cbind(freq=as.numeric(t(freqs[2,])))
rownames(rep) <- labels[,2]
rep

# Get regular violinplot using package ggplot2
g.es  <- ggplot(df,aes(x=grp,y=EffectSize)) + geom_violin(aes(group=grpN),scale="width",fill="grey40",color="grey40",trim=T,adjust=1)
# Cut at quantiles using vioQtile() in C-3PR
g.es0 <- vioQtile(g.es,qtiles=qtiles,probs=probs)
# Garnish
g.es1 <- g.es0 +
  ggtitle("B") + xlab("") + ylab("Effect Size") +
  scale_y_continuous(breaks=c(-.25,-.5,0,.25,.5,.75,1),limits=c(-.5,1)) + mytheme + theme(legend.position=c(.25,.165), legend.text=element_text(size=20), legend.title=element_text(size=22), axis.text.x=element_text(size=26),  axis.text.y=element_text(size=22), axis.title.y=element_text(size=30, vjust=2.6), title=element_text(size=27)) 
# View
g.es1

# # Uncomment to save panel B as a seperate file
# ggsave("RPP_F1_VQPes.eps",plot=g.es1)

# VIEW panels in one plot using the multi.PLOT() function from C-3PR
multi.PLOT(g.pv1,g.es1,cols=2)

13 References

Briscoe, M. H. (1996). Preparing scientific illustrations. Springer.

Open Science Collaboration (2015). Estimating the reproducibility of psychological science. Science, 349, 943.

Schweinsberg, M., Madan, N., Vianello, M., Sommer, S. A., Jordan, J., Tierney, W., Awtrey, E., Zhu, L., Diermeier, D., Heinze, J., Srinivasan, M., Tannenbaum, D., Bivolaru, E., Dana, J., Davis-Stober, C. P., Du Plessis, C. Gronau, Q. F., Hafenbrack, A. C., Liao, E. Y., Ly, A., Marsman, M., Murase, T., Qureshi, I., Schaerer, M., Thornley, N., Tworek, C. M., Wagenmakers, E-J., Wong, L., Anderson, T., Bauman, C. W., Bedwell, W. L., Brescoll, V., Canavan, A., Chandler, J. J., Cheries, E., Cheryan, S., Cheung, F., Cimpian, A., Clark, M., Cordon, D., Cushman, F., Ditto, P. H., Donahue, T., Frick, S. E., Gamez-Djokic, M., Hofstein Grady, R., Graham, J., Gu, J., Hahn, A., Hanson, B. E., Hartwich, N. J., Hein, K., Inbar, Y., Jiang, L., Kellogg, T., Kennedy, D. M., Legate, N., Luoma, T. P., Maibeucher, H., Meindl, P., Miles, J., Mislin, A., Molden, D. C., Motyl, M., Newman, G., Ngo, H. H., Packham, H., Ramsay, P. S., Ray, J. L., Sackett, A. M., Sellier, A-L., Sokolova, T., Sowden, W., Storage, D., Sun, X., Van Bavel, J. J., Washburn, A. N., Wei, C., Wetter, E., Wilson, C., Darroux, S-C., & Uhlmann, E. L. (in press). The pipeline project: Pre-publication independent replications of a single laboratory’s research pipeline. Journal of Experimental Social Psychology.

Verhagen, A. J., & Wagenmakers, E.-J. (2014). Bayesian tests to quantify the result of a replication attempt. Journal of Experimental Psychology: General, 143, 1457-1475.